Excel VBA code for finding corresponding pairs of data in two columns-CodePudding

I have a problem with the following code. I have data in columns A and C and want to find matching pairs that are identical in these two columns (column A and C). The pairs should receive an unique identifier in column B and D. This way I can filter out corresponding pairs from column A and C and have two remaining columns that cannot be matched. However, my code keeps looping trough the data when there are duplicates within a column and keeps assigning higher reference numbers.

Sub match()
    Dim c As Range, fn As Range, ref As Long
    ref = 1
        For Each c In Range("A2", Cells(Rows.Count, 1).End(xlUp))
            If c <> "" And c <> 0 Then
                Set fn = Range("C2", Cells(Rows.Count, 3).End(xlUp)).Find(c.Value, , xlValues, xlWhole)
                    If Not fn Is Nothing Then
                        adr = fn.Address
                        Do
                            If fn.Offset(, 1) = "" Then
                                c.Offset(, 1) = ref
                                fn.Offset(, 1) = ref
                                ref = ref   1
                            Else
                                Set fn = Range("C2", Cells(Rows.Count, 3).End(xlUp)).FindNext(fn)
                            End If
                        Loop While fn.Address <> adr
                    End If
            End If
        Next
        On Error Resume Next
        Range("B2", Cells(Rows.Count, 1).End(xlUp).Offset(, 1)).SpecialCells(xlCellTypeBlanks) = "Not found"
        Range("D2", Cells(Rows.Count, 3).End(xlUp).Offset(, 1)).SpecialCells(xlCellTypeBlanks) = "Not Found"
        On Error GoTo 0
        Err.Clear
    End Sub

Does anyone know a solution?

CodePudding user response：

You may benefit from MATCH in array form with Evaluate to fill the column D. The column B is the easy part, just MAX 1

Sub TEST()
Dim i As Long, j As Long
Dim rng_c As Range
Dim rng_b As Range
Dim LR As Long
Dim SR As Long
Dim Myf As WorksheetFunction
Set Myf = Application.WorksheetFunction 'to save some time typing

SR = 1 'starting row of data
LR = Range("A" & Rows.Count).End(xlUp).Row 'last row of data in column A

Set rng_b = Range("B" & SR & ":B" & LR) ' for column B
Set rng_c = Range("C" & SR & ":C" & LR) ' for column C

rng_b.Clear 'must be empty
Range("D" & SR & ":d" & LR).Clear 'must be empty

For i = SR To LR Step 1
    If Myf.CountIf(rng_c, Range("A" & i).Value) = 0 Then
        Range("B" & i).Value = "Not found"
    Else
        Range("B" & i).Value = Myf.Max(rng_b)   1
    End If
Next i

j = SR

For i = SR To LR Step 1
    If Range("B" & i).Value <> "Not found" Then
        j = Evaluate("MATCH(A" & i & ",C" & SR & ":C" & LR & "&D" & SR & ":D" & LR & ",0)")
        Range("D" & j).Value = Range("B" & i).Value
    End If
Next i

Set rng_b = Nothing
Set rng_c = Nothing
Set Myf = Nothing


End Sub

CodePudding user response：

You could do this without VBA at all, actually.
In D2, write this Formula:

=IF(COUNTIFS($A:$A, $A2, $C:$C, $C2)>1, IF(COUNTIFS($A$1:$A2, $A2, $C$1:$C2, $C2)=1, MAX($D$1:$D1) 1, XLOOKUP($A2 & $C2, $A$1:$A1 & $C$1:$C1, $D$1:$D1)), "Not Found")

Then copy that down column D, and make column B equal to column D

CodePudding user response：

There are several ways of doing this, but you were nearly there! Here are some slight adjustments:

Sub match()
    Dim c As Range, fn As Range, ref As Long
    
    'setting your ranges for clarity
    Dim rng As Range, rng2 As Range
    
    Set rng = Range("A2", Cells(Rows.Count, 1).End(xlUp))
    Set rng2 = Range("C2", Cells(Rows.Count, 3).End(xlUp))
    
    ref = 1
    For Each c In rng
        If c <> "" And c <> 0 Then
        
            'adding After:=rng2.Cells.Count
            Set fn = rng2.Find(c.Value, rng2.Cells(rng2.Cells.Count), xlValues, xlWhole)
                If Not fn Is Nothing Then
                    
                    Do
                    
                    'place inside Do ... Loop While
                    adr = fn.Address
                        
                        If fn.Offset(, 1) = "" Then
                            c.Offset(, 1) = ref
                            fn.Offset(, 1) = ref
                            ref = ref   1
                        Else
                            Set fn = rng2.FindNext(fn)
                        End If
                    Loop While fn.Address <> adr
                End If
        End If
    Next
    
    On Error Resume Next
    Range("B2", Cells(Rows.Count, 1).End(xlUp).Offset(, 1)).SpecialCells(xlCellTypeBlanks) = "Not found"
    Range("D2", Cells(Rows.Count, 3).End(xlUp).Offset(, 1)).SpecialCells(xlCellTypeBlanks) = "Not Found"
    On Error GoTo 0
    Err.Clear
End Sub

Problem 1: you forget to add the After parameter in .Find(...). See Using the .Find Function VBA - not returning the first value on why you need it.

Problem 2: the statement adr = fn.Address should be inside the Do ... Loop While, else you won't step out of the loop until after the last match; as a result you just kept overwriting the value in c.Offset(, 1) for A8 (leading to 6) and adding values for all its matches in column C (which explains values 4, 5, 6).