please make this code more efficient i am new

A

ap123

New Member
Joined
Feb 10, 2022
Messages
9
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
can someone make this code efficient

This code is meant to compare the revision between two workbooks
VBA Code: 
Sub Compare_Revision_MCC7021()

    'makes sure the button is only pushed when it is meant to be. simple check on the tab either side to make sure its the lastest Rev, and not the first'
    Rev_Number = Range("Z1")
    store = ActiveSheet.Index - 1
    store1 = ActiveSheet.Index + 1
    Next_Rev = Rev_Number + 1
    Previous = Rev_Number - 1
    If Worksheets(store1).Name <> "MCC7021 Rev " & Previous Then Exit Sub
    If Worksheets(store).Name = "MCC7021 Rev " & Next_Rev Then Exit Sub
  
    'variable used to count the removed cables, used later'
    Dim listing As Integer
    listing = 1
    Worksheets("Removed Cables").Range("B2:B100") = " "

    'steps through the cables'
    For cols = 7 To 500
  
        'stores all the cable info in there respective variable'
        Area_1 = Range("B" & cols)
        WBS_1 = Range("C" & cols)
        From_1 = Range("D" & cols)
        TAG_1 = Range("E" & cols)
        Power_1 = Range("F" & cols)
        Cable_1 = Range("G" & cols)
        FromD_1 = Range("H" & cols)
        ToD_1 = Range("I" & cols)
        Voltage_1 = Range("J" & cols)
        Length_1 = Range("K" & cols)
        Size_1 = Range("L" & cols)
        Cores_1 = Range("M" & cols)
        Type_1 = Range("N" & cols)
        Connection_1 = Range("O" & cols)
        Comments_1 = Range("P" & cols)
        REV_1 = Range("Q" & cols)
        Schematic_1 = Range("R" & cols)
        Block_1 = Range("S" & cols)
      
      
        'all of the following blocks of code follow the same formula'
        'using the cable number it looks up the desired cable infomation in the previous revision and compares it to the current revision'
        'if it is not the same it will highlight it blue (colour 37)'
        'if it is the same it is set to unhighlighted'
        'The "on error" lines of code just make sure that the code dosnt break if the cable isnt found in the previous revision'
      
      
        On Error Resume Next
        Area_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 2, False)
        On Error GoTo 0
        If Area_1 <> Area_2 Then
        Range("B" & cols).Interior.ColorIndex = 37
        End If
        If Area_1 = Area_2 Then
        Range("B" & cols).Interior.ColorIndex = 0
        End If
      
        On Error Resume Next
        WBS_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 3, False)
        On Error GoTo 0
        If WBS_1 <> WBS_2 Then
        Range("C" & cols).Interior.ColorIndex = 37
        End If
        If WBS_1 = WBS_2 Then
        Range("C" & cols).Interior.ColorIndex = 0
        End If
      
        On Error Resume Next
        From_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 4, False)
        On Error GoTo 0
        If From_1 <> From_2 Then
        Range("D" & cols).Interior.ColorIndex = 37
        End If
        If From_1 = From_2 Then
        Range("D" & cols).Interior.ColorIndex = 0
        End If
      
      
        On Error Resume Next
        Power_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 6, False)
        On Error GoTo 0
        If Power_1 <> Power_2 Then
        Range("F" & cols).Interior.ColorIndex = 37
        End If
        If Power_1 = Power_2 Then
        Range("F" & cols).Interior.ColorIndex = 0
        End If
      
        On Error Resume Next
        TAG_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 5, False)
        On Error GoTo 0
        If TAG_1 <> TAG_2 Then
        Range("E" & cols).Interior.ColorIndex = 37
        End If
        If TAG_1 = TAG_2 Then
        Range("E" & cols).Interior.ColorIndex = 0
        End If
      
        On Error Resume Next
        FromD_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 8, False)
        On Error GoTo 0
        If FromD_1 <> FromD_2 Then
        Range("H" & cols).Interior.ColorIndex = 37
        End If
        If FromD_1 = FromD_2 Then
        Range("H" & cols).Interior.ColorIndex = 0
        End If
      
        On Error Resume Next
        ToD_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 9, False)
        On Error GoTo 0
        If ToD_1 <> ToD_2 Then
        Range("I" & cols).Interior.ColorIndex = 37
        End If
        If ToD_1 = ToD_2 Then
        Range("I" & cols).Interior.ColorIndex = 0
        End If
      
        On Error Resume Next
        Voltage_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 10, False)
        On Error GoTo 0
        If Voltage_1 <> Voltage_2 Then
        Range("J" & cols).Interior.ColorIndex = 37
        End If
        If Voltage_1 = Voltage_2 Then
        Range("J" & cols).Interior.ColorIndex = 0
        End If
      
        On Error Resume Next
        Length_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 11, False)
        On Error GoTo 0
        If Length_1 <> Length_2 Then
        Range("K" & cols).Interior.ColorIndex = 37
        End If
        If Length_1 = Length_2 Then
        Range("K" & cols).Interior.ColorIndex = 0
        End If
      
        On Error Resume Next
        Size_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 12, False)
        On Error GoTo 0
        If Size_1 <> Size_2 Then
        Range("L" & cols).Interior.ColorIndex = 37
        End If
        If Size_1 = Size_2 Then
        Range("L" & cols).Interior.ColorIndex = 0
        End If
      
        On Error Resume Next
        Cores_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 13, False)
        On Error GoTo 0
        If Cores_1 <> Cores_2 Then
        Range("M" & cols).Interior.ColorIndex = 37
        End If
        If Cores_1 = Cores_2 Then
        Range("M" & cols).Interior.ColorIndex = 0
        End If
      
        On Error Resume Next
        Type_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 14, False)
        On Error GoTo 0
        If Type_1 <> Type_2 Then
        Range("N" & cols).Interior.ColorIndex = 37
        End If
        If Type_1 = Type_2 Then
        Range("N" & cols).Interior.ColorIndex = 0
        End If
      
        On Error Resume Next
        Connection_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 15, False)
        On Error GoTo 0
        If Connection_1 <> Connection_2 Then
        Range("O" & cols).Interior.ColorIndex = 37
        End If
        If Connection_1 = Connection_2 Then
        Range("O" & cols).Interior.ColorIndex = 0
        End If
      
        On Error Resume Next
        Comments_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 16, False)
        On Error GoTo 0
        If Comments_1 <> Comments_2 Then
        Range("P" & cols).Interior.ColorIndex = 37
        End If
        If Comments_1 = Comments_2 Then
        Range("P" & cols).Interior.ColorIndex = 0
        End If
      
        On Error Resume Next
        REV_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 17, False)
        On Error GoTo 0
        If REV_1 <> REV_2 Then
        Range("Q" & cols).Interior.ColorIndex = 37
        End If
        If REV_1 = REV_2 Then
        Range("Q" & cols).Interior.ColorIndex = 0
        End If
      
        On Error Resume Next
        REV_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 17, False)
        On Error GoTo 0
        If REV_1 <> REV_2 Then
        Range("Q" & cols).Interior.ColorIndex = 37
        End If
        If REV_1 = REV_2 Then
        Range("Q" & cols).Interior.ColorIndex = 0
        End If
      
        On Error Resume Next
        Schematic_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 18, False)
        On Error GoTo 0
        If Schematic_1 <> Schematic_2 Then
        Range("R" & cols).Interior.ColorIndex = 37
        End If
        If Schematic_1 = Schematic_2 Then
        Range("R" & cols).Interior.ColorIndex = 0
        End If
      
        On Error Resume Next
        Block_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 19, False)
        On Error GoTo 0
        If Block_1 <> Block_2 Then
        Range("S" & cols).Interior.ColorIndex = 37
        End If
        If Block_1 = Block_2 Then
        Range("S" & cols).Interior.ColorIndex = 0
        End If
      
        'if a new cable is added the entire row is highlighted'
        'the code row by row checks that each cable number is in the previous revision'
        Dim xlRange As Range
        Dim xlCell As Range
        Dim valueToFind
        Dim count As Integer
        count = 0
        valueToFind = Cable_1
        Set xlRange = Worksheets(store1).Range("A7:S500")

        For Each xlCell In xlRange
            If xlCell.Value = valueToFind Then
            count = count + 1
            End If
        Next xlCell
        If count = 0 Then
            Rows(cols).Interior.ColorIndex = 37
        End If
      
        On Error Resume Next
        Cable_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 7, False)
        On Error GoTo 0
      
        'same as before but in reverse. checking that every cable in the previous rev is in the current rev'
         'removed cables are recored on the removed cables tab'
      
        Code_2 = Worksheets(store1).Range("A" & cols)
        Dim xl2Range As Range
        Dim xl2Cell As Range
        Dim valueToFind2
        Dim count2 As Integer
        count2 = 0
        valueToFind2 = Code_2
        Set xl2Range = Range("A7:S500")

        For Each xl2Cell In xl2Range
            If xl2Cell.Value = valueToFind2 Then
            count2 = count2 + 1
            End If
        Next xl2Cell
        If count2 = 0 Then
            listing = listing + 1
            Dim prev_rev As String
            Dim c_rev As String
            prev_rev = Worksheets(store1).Name
            c_rev = ActiveSheet.Name
            Worksheets("Removed Cables").Range("B" & listing) = Cable_2 & "  From  " & prev_rev & "  To  " & c_rev
        End If

      
    'end of loop through each cable'
    Next cols
    'checks to see if the loop found any removed cables. if yes then a prompt will apear to let you know'
    If Worksheets("Removed Cables").Range("B2") <> " " Then
        MsgBox ("Some Cables Have Been Removed. Please Refer to the Removed Cables Sheet")
    End If


End Sub
 
Last edited by a moderator:
Sort by date Sort by votes
but it should not have highlighted because no changes have been made to those cells so i am not sure what is the persisting issue.
 
Upvote 0

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
I don't think you answered my previous question, does the original code work?
 
Upvote 0
now that i am looking back at it, it is highlighting cells that should not have highlighted in random instances so i don't know what to do
 
Upvote 0
If you are certain that the original code that you posted works 100% then let's try rolling my suggested code back a little bit:

VBA Code: 
Sub Compare_Revision_MCC7021V2()
'
'   variable used to count the removed cables, used later'
    Dim listing     As Long
'
    Dim count       As Long
    Dim xlCell      As Range
    Dim xlRange     As Range
    Dim valueToFind
'
'   makes sure the button is only pushed when it is meant to be. simple check on the tab either side to make sure its the lastest Rev, and not the first'
      Rev_Number = Range("Z1")
        Next_Rev = Rev_Number + 1
    Previous_Rev = Rev_Number - 1
           store = ActiveSheet.Index - 1
          store1 = ActiveSheet.Index + 1
'
    If Worksheets(store1).Name <> "MCC7021 Rev " & Previous_Rev Then Exit Sub
    If Worksheets(store).Name = "MCC7021 Rev " & Next_Rev Then Exit Sub
'
    Set xlRange = Worksheets(store1).Range("A7:S500")
'
    listing = 1
    Worksheets("Removed Cables").Range("B2:B100") = " "
'
'   steps through the cables'
    For RowNumber = 7 To 500
'
'   ColumnB  ColumnC  ColumnD  ColumnE  ColumnF  ColumnG  ColumnH  ColumnI  ColumnJ  ColumnK  ColumnL  ColumnM  ColumnN   ColumnO    ColumnP  ColumnQ    ColumnR
'   -------  -------  -------  -------  -------  -------  -------  -------  -------  -------  -------  -------  -------   -------    -------  -------    -------
'   Area_1   WBS_1    From_1   TAG_1    Power_1  Cable_1  FromD_1  ToD_1   Voltage_1 Length_1 Size_1   Cores_1  Type_1  Connection_1  REV_1  Schematic_1 Block_1
'
'
        Cable_1 = Range("G" & RowNumber)
'
        'the following block of code:'
        'using the cable number it looks up the desired cable infomation in the previous revision and compares it to the current revision'
        'if it is not the same it will highlight it blue (colour 37), if it is the same it is set to unhighlighted'
        'The "on error" lines of code just make sure that the code dosnt break if the cable isnt found in the previous revision'
'
        For ColumnNumber = 2 To 19
            If ColumnNumber = 7 Then ColumnNumber = ColumnNumber + 1                                                            ' Skip 7 ie. Column G
'
            On Error Resume Next
''            This_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), ColumnNumber, False)
            This_2 = Application.WorksheetFunction.VLookup(Cable_1, xlRange, ColumnNumber, False)
            On Error GoTo 0
            If Cells(RowNumber, ColumnNumber) <> This_2 Then Cells(RowNumber, ColumnNumber).Interior.ColorIndex = 37
            If Cells(RowNumber, ColumnNumber) = This_2 Then Cells(RowNumber, ColumnNumber).Interior.ColorIndex = 0
        Next
'
        
        
        
        'if a new cable is added the entire row is highlighted'
        'the code row by row checks that each cable number is in the previous revision'
        count = 0
        valueToFind = Cable_1
        Set xlRange = Worksheets(store1).Range("A7:S500")

        For Each xlCell In xlRange
            If xlCell.Value = valueToFind Then
            count = count + 1
            End If
        Next xlCell
        If count = 0 Then
            Rows(cols).Interior.ColorIndex = 37
        End If
      
        On Error Resume Next
        Cable_2 = Application.WorksheetFunction.VLookup(Cable_1, Worksheets(store1).Range("A7:S500"), 7, False)
        On Error GoTo 0
      
        'same as before but in reverse. checking that every cable in the previous rev is in the current rev'
         'removed cables are recored on the removed cables tab'
      
        Code_2 = Worksheets(store1).Range("A" & cols)
        Dim xl2Range As Range
        Dim xl2Cell As Range
        Dim valueToFind2
        Dim count2 As Integer
        count2 = 0
        valueToFind2 = Code_2
        Set xl2Range = Range("A7:S500")

        For Each xl2Cell In xl2Range
            If xl2Cell.Value = valueToFind2 Then
            count2 = count2 + 1
            End If
        Next xl2Cell
        If count2 = 0 Then
            listing = listing + 1
            Dim prev_rev As String
            Dim c_rev As String
            prev_rev = Worksheets(store1).Name
            c_rev = ActiveSheet.Name
            Worksheets("Removed Cables").Range("B" & listing) = Cable_2 & "  From  " & prev_rev & "  To  " & c_rev
        End If

      
    'end of loop through each cable'
    Next cols
    'checks to see if the loop found any removed cables. if yes then a prompt will apear to let you know'
    If Worksheets("Removed Cables").Range("B2") <> " " Then
        MsgBox ("Some Cables Have Been Removed. Please Refer to the Removed Cables Sheet")
    End If


End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Question Question
Unable to run VBA code
Replies
6
Views
165
RoryA
RoryA
J
  • Solved
VBA Code Error Unable to get the Match property of the WorksheetFunction class
Replies
8
Views
392
Jiraya_00
J
R
  • Solved
Make directory
Replies
6
Views
115
Joe4
Joe4
R
  • Question Question
Having Trouble getting this code in VBA to work. Attempting to download a list of PDFs
Replies
1
Views
148
6StringJazzer
6StringJazzer
edge37
  • Solved
Inserting more than one comment in a cell
Replies
4
Views
551
edge37
edge37

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top