CODEWITHSUNDEEP
excelvba
Tomas Perlecky
Tomas Perlecky

Reputation: 59

Compare and show differences in two columns, then show differences in multiple columns too

I have a sheet with data in 2 columns, A and B:

--A--     --B--
Apple     57
Orange    62
Lime      45
Orange    58
Apple     57
Orange    78
Lime      23
Melon     15

I need to search column A for duplicates, then if there are any, look for their value in column B. If they are different, I want to color the cell in column A to red, show the other value of that entry in column C, and show a message on how many indifferences there are. If there are more than 2 entries in Column A, and multiple different values in column B, then I want to show the other values in Columns C, D, E, etc. Something like this:

--A--     --B--   --C--   --D--
 Apple     57
 Orange    62       58     78
 Lime      45       23
 Orange    58       62     78
 Apple     57
 Orange    78       58     62
 Lime      23       45
 Melon     15

I have a code, which nearly does that, meaning that It shows the differences in Column C if there are only two of the same values in Column A. However, if there are more than 2 identical values in column A, then it gives incomplete data for columns C, D etc. Like this:

--A--     --B--   --C--
 Apple     57
 Orange    62       58  
 Lime      45       23
 Orange    58       78 
 Apple     57
 Orange    78       62 
 Lime      23       45
 Melon     15

Here is the code:

Dim pos As Variant 'match index
Dim rows As Integer
Dim i As Variant
Sheets("Chain").Range("C1:C1000").ClearContents
rows = Range("A:A").End(xlDown).Row 'Getting total row number
For i = 1 To rows

    'Find position of next occurence
    If i = 1 Then
    pos = WorksheetFunction.Match(Range("A" & i).Value, Range("A" & i & ":A" & rows + 1), 0) + i
    Else
    pos = WorksheetFunction.Match(Range("A" & i).Value, Range("A" & i + 1 & ":A" & rows + 1), 0) + i
    End If
    'If there is no next occurence find previous occurences
    If pos = 0 Then
    pos = WorksheetFunction.Match(Range("A" & i).Value, Range("A1:A" & i - 1), 0)

    End If

    On Error Resume Next

    Dim j As Integer
    Dim pos1 As Integer
    Dim pos2 As Integer
    j = i

    'While next occurence is same skip it
    While (Cells(i, 2) = Cells(pos, 2)) And (j < rows)
        j = 1 + pos
        pos1 = pos
        pos = WorksheetFunction.Match(Range("A" & i).Value, Range("A" & j & ":A" & rows + 1), 0) + j - 1
        pos2 = pos
        If pos1 = pos2 Then GoTo Endwhile

    Wend
Endwhile:

    'Writing into Column C
    Range("C" & i).Value = Cells(pos, 2).Value
    ' Highlighting duplicate cells
    If Cells(i, 2) <> Cells(i, 3) Then

    Range("A" & i).Interior.Color = TextBox5.BackColor
    End If

    If Cells(i, 2) = Cells(i, 3) Then Cells(i, 3) = ""
    pos = 0

Next i

'Final Message

Dim totdif As Integer
totdif = WorksheetFunction.CountA(Range("C1:C1" & rows))
If totdif = 0 Then
MsgBox "No indifferences found"
Else
MsgBox "Indifferences found: " & totdif
End If

Upvotes: 0

Views: 52

Answers (1)

Tim Williams
Tim Williams

Reputation: 166351

I'd be tempted to do it this way, using a dictionary to collect the unique values:

Sub Tester()

    Dim dict As Object, rng As Range, rw As Range, tmp, u As Long, vA, vB, e, n
    
    Set dict = CreateObject("scripting.dictionary")
    Set rng = ActiveSheet.Range("A1", Cells(Rows.Count, 1).End(xlUp)).Resize(, 2)
    rng.Offset(0, 2).Resize(, 50).ClearContents 'clear any previous results
    
    'first collect all ColB values for each unique colA value
    For Each rw In rng.Rows
        vA = rw.Cells(1).Value
        vB = rw.Cells(2).Value
        If Not dict.exists(vA) Then
            dict.Add vA, Array(vB) 'new key
        Else
            tmp = dict(vA)
            'already have this value for this key?
            If IsError(Application.Match(vB, tmp, 0)) Then
                u = UBound(tmp) + 1
                ReDim Preserve tmp(u)
                tmp(u) = vB 'add the new value
                dict(vA) = tmp
            End If
        End If
    Next rw
    
    'loop the rows again and add all the values
    For Each rw In rng.Rows
        vA = rw.Cells(1).Value
        vB = rw.Cells(2).Value
        
        tmp = dict(vA)
        'have >1 value ?
        If UBound(tmp) > 0 Then
            rw.Cells(1).Font.Color = vbRed
            n = n + 1
            For Each e In tmp
                'add if doesn't match the existing value on this row
                If e <> vB Then Cells(rw.Row, Columns.Count).End(xlToLeft).Offset(0, 1).Value = e
            Next e
        End If
    Next rw
    MsgBox n & " duplicates" 
End Sub

Upvotes: 1

Related Questions