CODEWITHSUNDEEP
arraysexcelvbacompare
DriveShaft1234
DriveShaft1234

Reputation: 13

How do you compare certain rows between two different sheets to each other?

My question is how to compare one column on one sheet to another column on another sheet and if they match, then a certain thing happens.

For all intents and purposes, I need to write a code that will turn the entire row of text yellow if column F on sheet 2 matches with column G on sheet 1 and also if column B on sheet 2 matches with column K on sheet 1 on the same row. So the code would go row by row comparing columns F and G and columns K and B and if they match on the same row, then the text in the entire row on sheet 1 will be turned yellow. This is my code so far.

Sub testhighlightdups()

Dim rng1 As Range, rng2 As Range, r As Long
    Dim dups As Object, k As String, rngDel As Range, rw As Range
    
    Set rng1 = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion
    Set rng2 = ThisWorkbook.Worksheets("Sheet2").Range("A1").CurrentRegion
    
    
    Set dups = RowKeyCount(rng2.Offset(1).Resize(rng2.Rows.Count - 1))
    
    
    For r = 2 To rng1.Rows.Count
        Set rw = rng1.Rows(r)
        k = RowKey(rw)
        If Len(k) > 0 And dups.exists(k) Then
            BuildRange rngDel, rw
            dups(k) = dups(k) - 1
            If dups(k) = 0 Then dups.Remove k
        End If
    Next r
    
   
    If Not rngDel Is Nothing Then rngDel.Font.Color = vbYellow 
    
End Sub

Function RowKeyCount(rng As Range) As Object
    Dim rw As Range, k As String, dict As Object
    Set dict = CreateObject("scripting.dictionary")
    For Each rw In rng.Rows
        k = RowKey(rw)
        If Len(k) > 0 Then dict(k) = dict(k) + 1
    Next rw
    Set RowKeyCount = dict
End Function


Function RowKey(rw As Range) As String
    If Application.CountA(rw) > 0 Then
        RowKey = rw.Worksheet.Evaluate("=TextJoin(""|"",FALSE," & rw.Address & ")")
    End If
End Function

Sub BuildRange(ByRef rngTot As Range, rngAdd As Range)
    If rngTot Is Nothing Then
        Set rngTot = rngAdd
    Else
        Set rngTot = Application.Union(rngTot, rngAdd)
    End If
End Sub

My problem with this code is that it does not compare on certain columns. It requires the entire row to be the exact same, rather than specific columns being compared to be the same.

Edit: Column F on sheet 2 is going to be the negative number of its counterpart on sheet 1. So, for example, the number will be -40 on column F on sheet 2. But on sheet 1 column G, it will be 40, not -40. Is there a way to code that the negative in front of the 40 is not a factor?

Upvotes: 0

Views: 68

Answers (1)

taller
taller

Reputation: 18898

The Function RowKey() creates a key using all the cells in a row for the Dictionary object. Alternatively, you can select specific columns to construct the key.

Option Explicit

Sub testhighlightdups()
    
    Dim rng1 As Range, rng2 As Range, r As Long, rngDel As Range
    
    Set rng1 = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion
    Set rng2 = ThisWorkbook.Worksheets("Sheet2").Range("A1").CurrentRegion
    ' Load data into an array
    Dim arr1: arr1 = rng1.Value
    Dim arr2: arr2 = rng2.Value
    
    Const SEP = "|"
    Dim sKey As String
    Dim dict As Object: Set dict = CreateObject("scripting.dictionary")
    ' assuming there is a header row, change to [r = LBound(arr2)] if not
    For r = LBound(arr2) + 1 To UBound(arr2)
        sKey = arr2(r, 2) & SEP & Abs(arr2(r, 6)) ' Col B & F
        If dict.exists(sKey) Then
            dict(sKey) = dict(sKey) + 1
        Else
            dict(sKey) = 1
        End If
    Next
    
    For r = LBound(arr1) + 1 To UBound(arr1)
        sKey = arr1(r, 11) & SEP & arr1(r, 7) ' Col K & G
        If dict.exists(sKey) Then
            If dict(sKey) > 0 Then
                BuildRange rngDel, rng1.Rows(r)
                dict(sKey) = dict(sKey) - 1
            End If
        End If
    Next
    
    If Not rngDel Is Nothing Then rngDel.Font.Color = vbYellow
    
End Sub

Sub BuildRange(ByRef rngTot As Range, rngAdd As Range)
    If rngTot Is Nothing Then
        Set rngTot = rngAdd
    Else
        Set rngTot = Application.Union(rngTot, rngAdd)
    End If
End Sub

Upvotes: 0

Related Questions