VBA Code that will match items from one sheet with items on another sheet

One to one matching is very straightforward, using either worksheet formulas or VBA code.

One to many matching is possible (though computationally intense) using Solver. You will find a number of PAQ in the Excel TA that use this approach, such as http:/Q_22017330.html  Although that PAQ uses worksheet formulas, it can be automated using VBA code. It will also do the one to one matching at the same time.

Many to many matching is enormously more computationally intense using Solver. I'm not sure the free version of Solver is even capable of doing it with a reasonable database. There are much more powerful versions of Solver available for purchase from its developer Frontline Systems--see http://www.solver.com/catalog/excel-products for details.

You requested to first match many to many, then proceed to one to many, and last with one to one. I suggest that the opposite order is more likely to get you an answer.

byundt, thanks for the reply. I would be happy to start with one to one if someone can provide the code.

I have written code for the one to one, and one to many bits. I don't know a good way of doing many to many, and so left that feature out.

As written, the MatchEm macro performs the one to one matches first. It then sorts the worksheets by the Match and Ref columns.

Next, it loops through the first worksheet for one to many matches with the second. It does this using Solver. After each match, it resorts the second worksheet.

Next, it loops through the second worksheet for one to many matches with the first. It does this using Solver. After each match, it resorts the first worksheet.

Finally, it sorts both first and second worksheets by Match and Ref. This leaves the many to many possibilities at the bottom.

Important!

You must install the Solver add-in before running the macro. You should be able to do this in the Developer...Add-ins menu item by checking the box for Solver.

You must also set a reference for the Solver add-in in each computer that will use the workbook. You do this in the VBA Editor by checking the box for Solver in Tools...References menu item. If everyone uses the same version of Excel, it will be checked automatically.

Sub MatchEm()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rg As Range, rgGoal1 As Range, rgRef1 As Range, rgMatch1 As Range, rgAmount1 As Range, _
    rgGoal2 As Range, rgRef2 As Range, rgMatch2 As Range, rgAmount2 As Range
Application.ScreenUpdating = False
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
With ws1
    Set rg = .UsedRange
    Set rgMatch1 = Intersect(rg, rg.Rows(1).Find("Match", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).EntireColumn)
    Set rgRef1 = Intersect(rg, rg.Rows(1).Find("Ref", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).EntireColumn)
    Set rgAmount1 = Intersect(rg, rg.Rows(1).Find("Amnt", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).EntireColumn)
    Set rgGoal1 = rg.Cells(1, rg.Columns.Count + 1)
End With
With ws2
    Set rg = .UsedRange
    Set rgMatch2 = Intersect(rg, rg.Rows(1).Find("Match", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).EntireColumn)
    Set rgRef2 = Intersect(rg, rg.Rows(1).Find("Ref", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).EntireColumn)
    Set rgAmount2 = Intersect(rg, rg.Rows(1).Find("Amnt", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).EntireColumn)
    Set rgGoal2 = rg.Cells(1, rg.Columns.Count + 1)
End With

Sorting ws1
Sorting ws2
OneToOne rgRef1, rgMatch1, rgAmount1, rgRef2, rgMatch2, rgAmount2
Sorting ws1
Sorting ws2
ws2.Activate
OneToMany rgRef1, rgMatch1, rgAmount1, rgRef2, rgMatch2, rgAmount2, rgGoal2
Sorting ws1
ws1.Activate
OneToMany rgRef2, rgMatch2, rgAmount2, rgRef1, rgMatch1, rgAmount1, rgGoal1
rgGoal1.ClearContents
rgGoal2.ClearContents
Sorting ws1
Sorting ws2
End Sub

Sub OneToMany(rgRef1 As Range, rgMatch1 As Range, rgAmount1 As Range, rgRef2 As Range, rgMatch2 As Range, rgAmount2 As Range, rgGoal As Range)
Dim i As Long, i1 As Long, i2 As Long, iSolver As Long, j As Long, jMatch As Long, n As Long, n1 As Long, n2 As Long
Dim vmatch As Variant
Dim cel As Range, rg As Range, rgAmount As Range, rgRef As Range, rgMatch As Range
Dim dAmount As Double
n1 = rgRef1.Rows.Count
n2 = rgRef2.Rows.Count
i1 = rgMatch1.Cells(n1 + 1).End(xlUp).Row - rgMatch1.Row + 2
jMatch = Application.Max(rgMatch1)
For i = i1 To n1
    i2 = rgMatch2.Cells(n2 + 1).End(xlUp).Row - rgMatch2.Row + 2
    Set rgRef = Range(rgRef2.Cells(i2, 1), rgRef2.Cells(n2, 1))
    vmatch = Application.Match(rgRef1.Cells(i, 1).Value, rgRef, 0)
    If Not IsError(vmatch) Then
        dAmount = rgAmount1.Cells(i, 1).Value
        Set rg = rgRef.Cells(vmatch, 1)
        n = Application.CountIf(Range(rg, rgRef2.Cells(n2, 1)), rgRef1.Cells(i, 1).Value)
        Set rg = rg.Resize(n)
        Set rgAmount = Intersect(rgAmount2, rg.EntireRow)
        Set rgMatch = Intersect(rgMatch2, rg.EntireRow)
        iSolver = SolveIt(dAmount, rgAmount, rgMatch, rgGoal)
        Select Case iSolver
        Case 0
            jMatch = jMatch + 1
            rgMatch1.Cells(i, 1).Value = jMatch
            For Each cel In rgMatch.Cells
                If Round(cel.Value, 2) = 1 Then
                    cel.Value = jMatch
                Else
                    cel.ClearContents
                End If
            Next
            Sorting rgAmount2.Worksheet
        Case Else
            rgMatch.ClearContents
        End Select
    End If
Next
End Sub

Function SolveIt(Target As Double, rgAmount As Range, rgMatch As Range, rgGoal As Range) As Long
Dim iResult As Long
Dim addrMatch As String, addrAmount As String, addrGoal As String
addrAmount = "'" & rgAmount.Worksheet.Name & "'!" & rgAmount.Address
addrMatch = "'" & rgMatch.Worksheet.Name & "'!" & rgMatch.Address
addrGoal = "'" & rgGoal.Worksheet.Name & "'!" & rgGoal.Address
rgMatch.FormulaArray = "1"
rgGoal.Formula = "=ROUND(SUMPRODUCT(" & addrAmount & "," & addrMatch & "),2)"
SolverReset
SolverOptions Precision:=0.001
SolverOk SetCell:=addrGoal, MaxMinVal:=3, ValueOf:=Target, ByChange:=addrMatch, Engine:=1, EngineDesc:="GRG Nonlinear"
SolverAdd CellRef:=addrMatch, Relation:=5, FormulaText:="binary"
iResult = SolverSolve(True)
SolveIt = iResult
End Function

Sub OneToOne(rgRef1 As Range, rgMatch1 As Range, rgAmount1 As Range, rgRef2 As Range, rgMatch2 As Range, rgAmount2 As Range)
Dim i As Long, i1 As Long, i2 As Long, j As Long, jMatch As Long, n As Long, n1 As Long, n2 As Long
Dim vmatch As Variant
Dim rg As Range, rgAmount As Range, rgRef As Range, rgMatch As Range
Dim dAmount As Double
n1 = rgRef1.Rows.Count
n2 = rgRef2.Rows.Count
i1 = rgMatch1.Cells(n1 + 1).End(xlUp).Row - rgMatch1.Row + 2
i2 = rgMatch2.Cells(n2 + 1).End(xlUp).Row - rgMatch2.Row + 2
jMatch = Application.Max(rgMatch1)
Set rgRef = Range(rgRef2.Cells(i1, 1), rgRef2.Cells(n2, 1))
For i = i1 To n1
    vmatch = Application.Match(rgRef1.Cells(i, 1).Value, rgRef, 0)
    If Not IsError(vmatch) Then
        dAmount = rgAmount1.Cells(i, 1).Value
        Set rg = rgRef.Cells(vmatch, 1)
        n = Application.CountIf(Range(rg, rgRef2.Cells(n2, 1)), rgRef1.Cells(i, 1).Value)
        Set rg = rg.Resize(n)
        Set rgAmount = Intersect(rgAmount2, rg.EntireRow)
        Set rgMatch = Intersect(rgMatch2, rg.EntireRow)
        For j = 1 To n
            If rgAmount.Cells(j, 1) = dAmount And rgMatch.Cells(j, 1) = "" Then
                jMatch = jMatch + 1
                rgMatch.Cells(j, 1) = jMatch
                rgMatch1.Cells(i, 1) = jMatch
                Exit For
            End If
        Next
    End If
Next
End Sub

Sub Sorting(ws As Worksheet)
'Sort the data first by Match column and then by Ref
Dim rg As Range, rgMatch As Range, rgRef As Range
With ws
    Set rg = .UsedRange
    Set rgMatch = Intersect(rg, rg.Rows(1).Find("Match", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).EntireColumn)
    Set rgRef = Intersect(rg, rg.Rows(1).Find("Ref", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).EntireColumn)
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=rgMatch.Offset(1, 0).Resize(rg.Rows.Count - 1), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Sort.SortFields.Add Key:=rgRef.Offset(1, 0).Resize(rg.Rows.Count - 1), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange rg
        .Header = xlYes
        .MatchCase = False
        .Apply
    End With
End With
End Sub

Select allOpen in new window

MatchV3.1Q28378136.xlsm

Hi byundt

what you have done looks brilliant. I have done a couple of tests but would like to leave open for a little while longer just in case I need to get back on anything.

Thanks

Hi

When I run it with my test data I get the following:

Sheet 1

Amnt      col F       col G       col H       col I       col J      Ref      Match
0                                    x150870103      1
7400                                    x376536108      2
1500                                    x376535100      5
4500                                    x376535100      5
100                                    x376546107      6
4500                                    x376535100      7

Sheet 2

Ref      col B      col C      col D      Amnt      Match
x150870103                              1
x376536108                        7400      2
x31678A103                        37      3
x31678A103                              4
x376535100                        6000      5
x376546107                              6
x376535100                        2900      7
x376535100                        1600      7


So: Not sure why but:

1 is returning a match although on Sheet 1 the amnt is 0 and blank on sheet 2
2 is fine
3 on sheet 2 is 37 but no 3 on Sheet 1
4 is blank on sheet 2 no Match 4 on sheet 1
5 is fine
6 is blank on Sheet 2 but on sheet 1 100
7 is fine.

does this make sense to you?

Thanks

Your sample data didn't have any blanks or zeros. I need to exclude those from the solution space. More code required.

I have also come up with an approach for the many to many matching. More code required for that as well.

Hi byundt

Sorry about that, I never gave it a thought that a blank or zero would make a difference.

Jagwarman,
Your question of matching is a problem that comes up from time to time in the Excel TA, usually from people who want to match payment checks to invoices. For this reason, I am putting a lot more time (four hours so far) into developing a general answer than I would ordinarily devote to an Experts Exchange question.

What time pressures do you face for a solution? I believe I can develop a complete solution, but it may take a day or two to work out all the issues.

Brad

I added the many to many feature as well as a test to exclude rows with zero amounts.

If it doesn't work at your end, please post a workbook with sample data that reproduces the problem.

Sub MatchEm()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rg As Range, rgGoal1 As Range, rgRef1 As Range, rgMatch1 As Range, rgAmount1 As Range, _
    rgGoal2 As Range, rgRef2 As Range, rgMatch2 As Range, rgAmount2 As Range
Application.ScreenUpdating = False
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
With ws1
    Set rg = .UsedRange
    Set rgMatch1 = Intersect(rg, rg.Rows(1).Find("Match", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).EntireColumn)
    Set rgRef1 = Intersect(rg, rg.Rows(1).Find("Ref", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).EntireColumn)
    Set rgAmount1 = Intersect(rg, rg.Rows(1).Find("Amnt", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).EntireColumn)
    Set rgGoal1 = rg.Cells(1, rg.Columns.Count + 1)
End With
With ws2
    Set rg = .UsedRange
    Set rgMatch2 = Intersect(rg, rg.Rows(1).Find("Match", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).EntireColumn)
    Set rgRef2 = Intersect(rg, rg.Rows(1).Find("Ref", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).EntireColumn)
    Set rgAmount2 = Intersect(rg, rg.Rows(1).Find("Amnt", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).EntireColumn)
    Set rgGoal2 = rg.Cells(1, rg.Columns.Count + 1)
End With

NoMatchForZero rgMatch1, rgAmount1
NoMatchForZero rgMatch2, rgAmount2
Sorting ws1
Sorting ws2
OneToOne rgRef1, rgMatch1, rgAmount1, rgRef2, rgMatch2, rgAmount2
Sorting ws1
Sorting ws2
ws2.Activate
OneToMany rgRef1, rgMatch1, rgAmount1, rgRef2, rgMatch2, rgAmount2, rgGoal2
Sorting ws1
Sorting ws2
ws1.Activate
OneToMany rgRef2, rgMatch2, rgAmount2, rgRef1, rgMatch1, rgAmount1, rgGoal1
Sorting ws1
Sorting ws2
ws2.Activate
ManyToMany rgRef1, rgMatch1, rgAmount1, rgRef2, rgMatch2, rgAmount2, rgGoal2
NoMatchesHere rgMatch2
rgGoal1.ClearContents
rgGoal2.ClearContents
Sorting ws1
Sorting ws2
End Sub


Sub ManyToMany(rgRef1 As Range, rgMatch1 As Range, rgAmount1 As Range, rgRef2 As Range, rgMatch2 As Range, rgAmount2 As Range, rgGoal As Range)
Dim i As Long, i1 As Long, i2 As Long, iSolver As Long, j As Long, jMatch As Long, _
    n As Long, n1 As Long, n2 As Long, nn1 As Long, nn2 As Long
Dim vmatch As Variant
Dim cel As Range, rgRef As Range
Dim rggRef1 As Range, rggMatch1 As Range, rggAmount1 As Range, rggRef2 As Range, rggMatch2 As Range, rggAmount2 As Range
Dim dAmount As Double
Dim vArray As Variant
n1 = rgRef1.Rows.Count
n2 = rgRef2.Rows.Count
i1 = rgMatch1.Cells(n1 + 1).End(xlUp).Row - rgMatch1.Row + 2
For i = i1 To n1
    Do
        i1 = rgMatch1.Cells(n1 + 1).End(xlUp).Row - rgMatch1.Row + 2
        If i1 = n1 Then Exit Do
        
        jMatch = Application.Max(rgMatch1)
        Set rgRef = Range(rgRef1.Cells(i1, 1), rgRef1.Cells(n1, 1))
        nn1 = Application.CountIf(rgRef, rgRef.Cells(1, 1).Value)
        If IsEmpty(vArray) Then ReDim vArray(1 To nn1)
        If nn1 <> UBound(vArray) Then ReDim vArray(1 To nn1)
        Set rggRef1 = rgRef1.Cells(i1, 1).Resize(nn1)
        Set rggMatch1 = rgMatch1.Cells(i1, 1).Resize(nn1)
        Set rggAmount1 = rgAmount1.Cells(i1, 1).Resize(nn1)
        
        i2 = rgMatch2.Cells(n2 + 1).End(xlUp).Row - rgMatch2.Row + 2
        Set rgRef = Range(rgRef2.Cells(i2, 1), rgRef2.Cells(n2, 1))
        vmatch = Application.Match(rgRef1.Cells(i1, 1).Value, rgRef, 0)
        If Not IsError(vmatch) Then
            Set rgRef = Range(rgRef.Cells(vmatch, 1), rgRef2.Cells(n2, 1))
            nn2 = Application.CountIf(rgRef, rgRef.Cells(1, 1).Value)
            Set rggRef2 = rgRef2.Cells(rgRef.Row + vmatch - 1, 1).Resize(nn2)
            Set rggMatch2 = rgMatch2.Cells(rgRef.Row + vmatch - 1, 1).Resize(nn2)
            Set rggAmount2 = rgAmount2.Cells(rgRef.Row + vmatch - 1, 1).Resize(nn2)
            
            NextCombo vArray
            If vArray(LBound(vArray)) < 0 Then Exit Do
            dAmount = SumIff(vArray, rggAmount1)
            iSolver = SolveIt(dAmount, rggAmount2, rggMatch2, rgGoal)
            Select Case iSolver
            Case 0
                jMatch = jMatch + 1
                UpdateMatches vArray, rggMatch1, jMatch
                For Each cel In rggMatch2.Cells
                    If Round(cel.Value, 2) = 1 Then
                        cel.Value = jMatch
                    Else
                        cel.ClearContents
                    End If
                Next
                Sorting rgAmount2.Worksheet
                ReDim vArray(1 To nn1)
            Case Else
                rggMatch2.ClearContents
            End Select
        Else
            rggMatch1.Value = "No match"
            Exit Do
        End If
    Loop
    NoMatchesHere rggMatch1
    i = rgMatch1.Cells(n1 + 1).End(xlUp).Row - rgMatch1.Row + 1
Next
End Sub

Sub NextCombo(vArray As Variant)
'Increments vArray by 1 as through it were a binary number. Least significant bit is first element in vArray.
Dim i As Long, n As Long
Dim bCarry As Boolean
n = UBound(vArray)
bCarry = True
Do
    For i = LBound(vArray) To n
        If bCarry = True Then
            If vArray(i) = 0 Then
                vArray(i) = 1
                bCarry = False
            Else
                vArray(i) = 0
            End If
        End If
    Next
    If bCarry = True Then
        vArray(LBound(vArray)) = -1
        Exit Do
    Else
        If Application.Sum(vArray) < 2 Then
            bCarry = True
        Else
            Exit Do
        End If
    End If
Loop
End Sub

Sub NoMatchForZero(rgMatch As Range, rgAmount As Range)
Dim i As Long, n As Long
n = rgAmount.Rows.Count
For i = 1 To n
    If rgAmount.Cells(i, 1).Value = 0 Then rgMatch.Cells(i, 1).Value = "No match"
Next
End Sub

Sub NoMatchesHere(rgMatch As Range)
Dim cel As Range
For Each cel In rgMatch.Cells
    If cel.Value = 0 Then cel.Value = "No match"
Next
End Sub

Sub OneToMany(rgRef1 As Range, rgMatch1 As Range, rgAmount1 As Range, rgRef2 As Range, rgMatch2 As Range, rgAmount2 As Range, rgGoal As Range)
Dim i As Long, i1 As Long, i2 As Long, iSolver As Long, j As Long, jMatch As Long, n As Long, n1 As Long, n2 As Long
Dim vmatch As Variant
Dim cel As Range, rg As Range, rgAmount As Range, rgRef As Range, rgMatch As Range
Dim dAmount As Double
n1 = rgRef1.Rows.Count
n2 = rgRef2.Rows.Count
i1 = rgMatch1.Cells(n1 + 1).End(xlUp).Row - rgMatch1.Row + 2
jMatch = Application.Max(rgMatch1)
For i = i1 To n1
    i2 = rgMatch2.Cells(n2 + 1).End(xlUp).Row - rgMatch2.Row + 2
    Set rgRef = Range(rgRef2.Cells(i2, 1), rgRef2.Cells(n2, 1))
    vmatch = Application.Match(rgRef1.Cells(i, 1).Value, rgRef, 0)
    If Not IsError(vmatch) Then
        dAmount = rgAmount1.Cells(i, 1).Value
        Set rg = rgRef.Cells(vmatch, 1)
        n = Application.CountIf(Range(rg, rgRef2.Cells(n2, 1)), rgRef1.Cells(i, 1).Value)
        Set rg = rg.Resize(n)
        Set rgAmount = Intersect(rgAmount2, rg.EntireRow)
        Set rgMatch = Intersect(rgMatch2, rg.EntireRow)
        iSolver = SolveIt(dAmount, rgAmount, rgMatch, rgGoal)
        Select Case iSolver
        Case 0
            jMatch = jMatch + 1
            rgMatch1.Cells(i, 1).Value = jMatch
            For Each cel In rgMatch.Cells
                If Round(cel.Value, 2) = 1 Then
                    cel.Value = jMatch
                Else
                    cel.ClearContents
                End If
            Next
            Sorting rgAmount2.Worksheet
        Case Else
            rgMatch.ClearContents
        End Select
    End If
Next
End Sub

Sub OneToOne(rgRef1 As Range, rgMatch1 As Range, rgAmount1 As Range, rgRef2 As Range, rgMatch2 As Range, rgAmount2 As Range)
Dim i As Long, i1 As Long, i2 As Long, j As Long, jMatch As Long, n As Long, n1 As Long, n2 As Long
Dim vmatch As Variant
Dim rg As Range, rgAmount As Range, rgRef As Range, rgMatch As Range
Dim dAmount As Double
n1 = rgRef1.Rows.Count
n2 = rgRef2.Rows.Count
i1 = rgMatch1.Cells(n1 + 1).End(xlUp).Row - rgMatch1.Row + 2
i2 = rgMatch2.Cells(n2 + 1).End(xlUp).Row - rgMatch2.Row + 2
jMatch = Application.Max(rgMatch1)
Set rgRef = Range(rgRef2.Cells(i1, 1), rgRef2.Cells(n2, 1))
For i = i1 To n1
    vmatch = Application.Match(rgRef1.Cells(i, 1).Value, rgRef, 0)
    If Not IsError(vmatch) Then
        dAmount = rgAmount1.Cells(i, 1).Value
        Set rg = rgRef.Cells(vmatch, 1)
        n = Application.CountIf(Range(rg, rgRef2.Cells(n2, 1)), rgRef1.Cells(i, 1).Value)
        Set rg = rg.Resize(n)
        Set rgAmount = Intersect(rgAmount2, rg.EntireRow)
        Set rgMatch = Intersect(rgMatch2, rg.EntireRow)
        For j = 1 To n
            If rgAmount.Cells(j, 1) = dAmount And rgMatch.Cells(j, 1) = "" Then
                jMatch = jMatch + 1
                rgMatch.Cells(j, 1) = jMatch
                rgMatch1.Cells(i, 1) = jMatch
                Exit For
            End If
        Next
    End If
Next
End Sub

Sub Sorting(ws As Worksheet)
'Sort the data first by Match column and then by Ref
Dim rg As Range, rgMatch As Range, rgRef As Range
With ws
    Set rg = .UsedRange
    Set rgMatch = Intersect(rg, rg.Rows(1).Find("Match", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).EntireColumn)
    Set rgRef = Intersect(rg, rg.Rows(1).Find("Ref", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).EntireColumn)
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=rgMatch.Offset(1, 0).Resize(rg.Rows.Count - 1), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Sort.SortFields.Add Key:=rgRef.Offset(1, 0).Resize(rg.Rows.Count - 1), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange rg
        .Header = xlYes
        .MatchCase = False
        .Apply
    End With
End With
End Sub

Sub UpdateMatches(vArray As Variant, rgMatch As Range, jMatch As Long)
Dim v As Variant
Dim i As Long
For Each v In vArray
    i = i + 1
    If v = 1 Then
        rgMatch.Cells(i, 1).Value = jMatch
    Else
        rgMatch.Cells(i, 1).ClearContents
    End If
Next
End Sub

Private Function SolveIt(Target As Double, rgAmount As Range, rgMatch As Range, rgGoal As Range) As Long
Dim iResult As Long
Dim addrMatch As String, addrAmount As String, addrGoal As String
addrAmount = "'" & rgAmount.Worksheet.Name & "'!" & rgAmount.Address
addrMatch = "'" & rgMatch.Worksheet.Name & "'!" & rgMatch.Address
addrGoal = "'" & rgGoal.Worksheet.Name & "'!" & rgGoal.Address
rgMatch.FormulaArray = "1"
rgGoal.Formula = "=ROUND(SUMPRODUCT(" & addrAmount & "," & addrMatch & "),2)"
SolverReset
SolverOptions Precision:=0.001
SolverOk SetCell:=addrGoal, MaxMinVal:=3, ValueOf:=Target, ByChange:=addrMatch, Engine:=1, EngineDesc:="GRG Nonlinear"
SolverAdd CellRef:=addrMatch, Relation:=5, FormulaText:="binary"
iResult = SolverSolve(True)
SolveIt = iResult
End Function

Private Function SumIff(vArray As Variant, rgAmount As Range) As Double
Dim d As Double
Dim i As Long
Dim v As Variant
For Each v In vArray
    i = i + 1
    If v = 1 Then d = d + rgAmount.Cells(i, 1)
Next
SumIff = d
End Function

Select allOpen in new window

MatchV3.1Q28378136.xlsm

Hi Brad

this is absolutely brilliant. I really appreciate your time and effort on this. If it was possible I would give you much more than 500 points for this one.

Its doing exactly what I needed which is great. I do have a question though. I will be able to use this on several other files that we need to perform reconciliations on and to do this I will need to change certain parts of the macro where it refers to Ref, Amnt and also the column where you put the Match No.

As I am relatively new to VBA I don't want to break what you have done, would you be able to advise me what to change.

Once again many thanks.

Hi again Brad

I have run my test file against it but in the end I had to 'End Task' as it just ran and ran. I have attached the file so that you can see the data and maybe figure out why it is running for so long. On sheet 1 there are 112 rows and on Sheet 2 there are 49.

Thanks Regards
MatchV3.1Q28378136-1.xlsm

Jagwarman,
Thanks for posting some more challenging sample data.

The code runs to completion at my end, but it takes almost six minutes, and is giving unexpected results for the many to many relationships.

I have an idea for speeding it up, and will post back when it is coded and tested.

Brad

Ok thank you Brad

several other files that we need to perform reconciliations on and to do this I will need to change certain parts of the macro where it refers to Ref, Amnt and also the column where you put the Match No.

The MatchEm sub is looking for specific text in the header labels: "Ref", "Amnt" and "Match". I put these values in Const statements (with comments) at the very top of the code. Change these values to match what you actually have in your data. It doesn't matter which columns contain that text, as long as they are left of any other columns that might contain the same text. Capitalization is not important.

Brad this looks brilliant I have tested once only today as I have had a mare of a day but will test fully on Monday. Thanks for all your effort. Have a great weekend.

Regards
John

just read your profile, FYI I have 29 year old twin boys.

Hi Brad,

Well I have tested on my files today and it really is brilliant, exactly what I was looking for it to do.

Thanks for all the time and effort you put into providing the exact thing I asked for.

Will have to see if I can come up with something more challenging for you :-)

I really did not think any expert would come up with the answer to my question, but, byundt delivers an amazing solution. Thanks

Brad,

I come up against a problem, can you throw any light on it?

The items in the attached file should match but they are saying No Match

Can you take a look

Thanks
MatchV3.2.xlsm

Sorry Brad, something weird is happening.

When I ran the file again that I attached they matched.

In my file they don't

x131193104            100      No match            No match
x131193104      100            No match            No match

100      x131193104            No match


100      x131193104            No match


Don't know if you will be able to throw any light on it?

Thanks

I made a mistake in sub OneToOne sub when setting the range for rgRef (statement 13). The reference to i1 should have been to i2. The corrected version is shown below.

After making the change to that sub in both Module3 and Module4, the code is now working. For test purposes, I removed the conditional formatting from the match columns.

Sub OneToOne(rgRef1 As Range, rgMatch1 As Range, rgAmount1 As Range, rgRef2 As Range, rgMatch2 As Range, rgAmount2 As Range)
Dim i As Long, i1 As Long, i2 As Long, j As Long, jMatch As Long, n As Long, n1 As Long, n2 As Long
Dim vmatch As Variant
Dim rg As Range, rgAmount As Range, rgRef As Range, rgMatch As Range
Dim dAmount As Double
SortMatches rgMatch1, rgRef1
SortMatches rgMatch2, rgRef2
n1 = rgRef1.Rows.Count
n2 = rgRef2.Rows.Count
i1 = rgMatch1.Cells(n1 + 1).End(xlUp).Row - rgMatch1.Row + 2
i2 = rgMatch2.Cells(n2 + 1).End(xlUp).Row - rgMatch2.Row + 2
jMatch = Application.Max(rgMatch1)
Set rgRef = Range(rgRef2.Cells(i2, 1), rgRef2.Cells(n2, 1))
For i = i1 To n1
    vmatch = Application.Match(rgRef1.Cells(i, 1).Value, rgRef, 0)
    If Not IsError(vmatch) Then
        dAmount = rgAmount1.Cells(i, 1).Value
        Set rg = rgRef.Cells(vmatch, 1)
        n = Application.CountIf(Range(rg, rgRef2.Cells(n2, 1)), rgRef1.Cells(i, 1).Value)
        Set rg = rg.Resize(n)
        Set rgAmount = Intersect(rgAmount2, rg.EntireRow)
        Set rgMatch = Intersect(rgMatch2, rg.EntireRow)
        For j = 1 To n
            If rgAmount.Cells(j, 1) = dAmount And rgMatch.Cells(j, 1) = "" Then
                jMatch = jMatch + 1
                rgMatch.Cells(j, 1) = jMatch
                rgMatch1.Cells(i, 1) = jMatch
                Exit For
            End If
        Next
    End If
Next
End Sub

Select allOpen in new window

Ok thanks Brad had to leave for the day will re test tomorrow

John,
After seeing how you had to modify my code for deployment, I changed it to make that process easier for you. With the change, you just need to modify a short sub that calls the rest of the code with the values of the constants (header labels and worksheet names). Look at MatchEmBorrow and MatchEmLoan in the snippet below.

The changes include moving all the constants but cnPrecision into MatchEmBorrow and MatchEmLoan, changing the function definition for MatchEm, and deleting the statements in MatchEm that set references to ws1 and ws2.

I also found a mistake in the ManyToMany sub. It has been fixed in statements 101 & 102 below.

I incorporated these changes into both your most recent test file and the one I had been using for code development. Both are attached.

Const cnPrecision As Double = 0.001     'Sums must match within this amount

Sub MatchEmBorrow()
Const cnRef As String = "Ref"           'Header label. Look only for sums with the same Ref number
Const cnAmount As String = "Amnt"       'Header label. Values to be summed, then compared
Const cnMatch As String = "Match_1"       'Header label. Sequential number for each matching combination.
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")          'Worksheet containing first list of references and amounts
Set ws2 = Worksheets("Sheet3")          'Worksheet containing second list of references and amounts
MatchEm ws1, ws2, cnRef, cnAmount, cnMatch
End Sub

Sub MatchEmLoan()
Const cnRef As String = "Ref"           'Header label. Look only for sums with the same Ref number
Const cnAmount As String = "Amnt2"       'Header label. Values to be summed, then compared
Const cnMatch As String = "Match_2"       'Header label. Sequential number for each matching combination.
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("Sheet2")          'Worksheet containing first list of references and amounts
Set ws2 = Worksheets("Sheet3")          'Worksheet containing second list of references and amounts
MatchEm ws1, ws2, cnRef, cnAmount, cnMatch
End Sub

Sub MatchEm(ws1 As Worksheet, ws2 As Worksheet, cnRef As String, cnAmount As String, cnMatch As String)
Dim rg1 As Range, rgRef1 As Range, rgMatch1 As Range, rgAmount1 As Range, _
    rg2 As Range, rgRef2 As Range, rgMatch2 As Range, rgAmount2 As Range
Dim dTimer As Double
Dim nCol1 As Long, nCol2 As Long, nRow1 As Long, nRow2 As Long
dTimer = Timer
Application.ScreenUpdating = False
With ws1
    Set rg1 = .Rows(1).Find(cnRef, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    nRow1 = .Cells(.Rows.Count, rg1.Column).End(xlUp).Row
    nCol1 = .Cells(1, .Columns.Count).End(xlToLeft).Column
    Set rgRef1 = rg1.Resize(nRow1)
    Set rg1 = Range(.Cells(1, 1), .Cells(nRow1, nCol1))
    Set rgMatch1 = .Rows(1).Find(cnMatch, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Resize(nRow1)
    Set rgAmount1 = .Rows(1).Find(cnAmount, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Resize(nRow1)
End With
With ws2
    Set rg2 = .Rows(1).Find(cnRef, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    nRow2 = .Cells(.Rows.Count, rg2.Column).End(xlUp).Row
    nCol2 = .Cells(1, .Columns.Count).End(xlToLeft).Column
    Set rgRef2 = rg2.Resize(nRow2)
    Set rg2 = Range(.Cells(1, 1), .Cells(nRow2, nCol2))
    Set rgMatch2 = .Rows(1).Find(cnMatch, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).Resize(nRow2)
    Set rgAmount2 = .Rows(1).Find(cnAmount, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Resize(nRow2)
End With

NoMatchForZero rgMatch1, rgAmount1
NoMatchForZero rgMatch2, rgAmount2
OneToOne rgRef1, rgMatch1, rgAmount1, rgRef2, rgMatch2, rgAmount2
ManyToManyMatching rgRef1, rgMatch1, rgAmount1, rgRef2, rgMatch2, rgAmount2, True
ManyToManyMatching rgRef2, rgMatch2, rgAmount2, rgRef1, rgMatch1, rgAmount1, True
ManyToManyMatching rgRef1, rgMatch1, rgAmount1, rgRef2, rgMatch2, rgAmount2, False
NoMatchesHere rgMatch1
NoMatchesHere rgMatch2
SortMatches rgMatch1, rgRef1
SortMatches rgMatch2, rgRef2
Debug.Print Timer - dTimer
End Sub

Sub ManyToManyMatching(rgRef1 As Range, rgMatch1 As Range, rgAmount1 As Range, _
    rgRef2 As Range, rgMatch2 As Range, rgAmount2 As Range, bSingleItem As Boolean)
'Loops through the rows in worksheet1 where rgMatch1 does not have a value. Looks for matches on worksheet2. _
    Uses ManyToMany to test the sum of all the combinations of rgAmount1 items (for a given rgRef1 value) on worksheet1 _
    for matching sum of all the combinations of rgAmount2 items (for the same rgRef1 value) on worksheet2.
'For each match found, puts a sequential number in rgMatch1 and rgMatch2
'If bSingleItem is True, tests single items on worksheet1 rather than combinations
Dim i As Long, i1 As Long, i2 As Long, iNext As Long, j As Long, jMatch As Long, _
    n1 As Long, n2 As Long, nn1 As Long, nn2 As Long
Dim vmatch As Variant
Dim cel As Range, rgRef As Range
Dim rggMatch1 As Range, rggAmount1 As Range, rggMatch2 As Range, rggAmount2 As Range
Dim vAmount1 As Variant, vAmount2 As Variant
Dim vArray1 As Variant, vArray2 As Variant
ClearNoSingleMatches rgMatch1
ClearNoSingleMatches rgMatch2
SortMatches rgMatch1, rgRef1
SortMatches rgMatch2, rgRef2
n1 = rgRef1.Rows.Count
n2 = rgRef2.Rows.Count
i1 = rgMatch1.Cells(n1 + 1).End(xlUp).Row - rgMatch1.Row + 2
Do
    If i1 >= n1 Then Exit Do
    
    jMatch = Application.Max(rgMatch1)
    Set rgRef = Range(rgRef1.Cells(i1, 1), rgRef1.Cells(n1, 1))
    nn1 = Application.CountIf(rgRef, rgRef.Cells(1, 1).Value)
    iNext = i1 + nn1    'Index number of next Ref
    ReDim vArray1(1 To nn1)
    Set rggMatch1 = rgMatch1.Cells(i1, 1).Resize(nn1)
    vAmount1 = rgAmount1.Cells(i1, 1).Resize(nn1).Value
    
    i2 = rgMatch2.Cells(n2 + 1).End(xlUp).Row - rgMatch2.Row + 2
    Set rgRef = Range(rgRef2.Cells(i2, 1), rgRef2.Cells(n2, 1))
    vmatch = Application.Match(rgRef1.Cells(i1, 1).Value, rgRef, 0)
    If Not IsError(vmatch) Then
        Set rgRef = Range(rgRef.Cells(vmatch, 1), rgRef2.Cells(n2, 1))
        nn2 = Application.CountIf(rgRef, rgRef.Cells(1, 1).Value)
        ReDim vArray2(1 To nn2)
        Set rggMatch2 = rgMatch2.Cells(rgRef.Row, 1).Resize(nn2)
        vAmount2 = rgAmount2.Cells(rgRef.Row, 1).Resize(nn2).Value
        If ManyToMany(vAmount1, vArray1, vAmount2, vArray2, bSingleItem) Then
            jMatch = jMatch + 1
            UpdateMatches vArray1, rggMatch1, jMatch
            UpdateMatches vArray2, rggMatch2, jMatch
            SortMatches rgMatch1, rgRef1
            SortMatches rgMatch2, rgRef2
            i1 = i1 + Application.Sum(vArray1)
        Else
            i1 = iNext
        End If
    Else
        i1 = iNext
    End If
Loop
End Sub

Select allOpen in new window

Brad
MatchV3.2-Q28378136.xlsm
MatchV3.2Q28378136-3.xlsm

Hi Brad,

perfect. Thank you it is working great.

Kind Regards
John

Hi Brad,

I need more help with this but I am not sure if you will see this to pick it up. Can you let me know please

Thanks
Regards
John

I always continue subscribing to questions

Brad

Hi brad,

thanks for getting back. I seriously need your help.

If there are only a few rows of data it works fine and it's fast.

If there are many rows it goes into 'Not Responding' and takes for ever. [15-20 mins or more]

Would it be ok if I save down a file for you to look at?

John

John,
Please do post a file for me to look at.

Remember though, that many to many matching is a computationally difficult problem. Success at reducing the "Not Responding" time will require limiting the number of elements that you are trying to match up.

Brad

Brad,

Understood, appreciate your help.

Regards
John
JKTest.xlsm

John,
Your many to many matching problem is computationally very difficult. It gets exponentially more difficult as the number of items goes up.

Your problem is that there are 80 entries with Cus = x1567 on worksheet Payable and 40 on worksheet Receivable. Assuming that none of those entries are removed by one to one matching, the code potentially needs to look at 2^80 (1.2 septillion) combinations on Payable and 2^40 (1.1 trillion) combinations on Receivable.

Anything that you can do to reduce the number of x1567 entries on worksheet Payable would be of big benefit to your recalc time. For example, if you know that no more than 5 entries may belong to a valid combination, that would drop the number of combinations to be tested on worksheet Payable from 1.2 septillion to a mere 25.7 million. The code would need to be rewritten to use that approach, but there is a significant improvement possible.

Brad

Hi Brad,

wow those numbers are mind boggeling. I would definitely say we can go with 5 if that speeds up the process. Would you be able to do this for me?

Thanks in advance.

John

John,
The coding took longer than I anticipated, but it seems to be working.

I made the number of items in a combination a variable. It is limited by the Constant MaxItems at the top of the module sheet. For testing, I set it at 3.

As written, the code first tries to match one to one, then one to many. Finally, it does many to many. The idea is to eliminate as many items as possible before running the extremely time-consuming many to many matching.

When performing one to many or many to many matching, the code first tries combinations of 2 items. When all possibilities have been tried, it then tries combinations of 3 items. Then 4, and so on up to the limit set by MaxItems.

If the number of items (for a given customer ID) is say 20, there will be a limited number of combinations of 2 items (20*19/(2) = 190). There will be more combinations of 3 items (20*19*18/(3*2) = 540). I trust you see that shortening the list by testing combinations of 2 before testing combinations of 3 improves overall computational efficiency.

The corollary of that strategy is that it takes noticeably longer with each increase in the value of MaxItems. You'll need to trade off the amount of time taken with the increased number (if any) of matches when you change the value of MaxItems.

The posted workbook includes two extra worksheets with a very short dataset that I used for debugging. You can delete Sheet1 and Sheet2 (along with sub MatchTest) when you are satisfied that everything is working well.

Const cnPrecision As Double = 0.001     'Sums must match within this amount
Const MaxItems As Long = 3              'When building combinations, use at most this number of items

Sub MatchEmBorrow()
Const cnRef As String = "CUS"           'Header label. Look only for sums with the same Ref number
Const cnAmount As String = "Borrows"       'Header label. Values to be summed, then compared
Const cnMatch As String = "Match_Pay"       'Header label. Sequential number for each matching combination.
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("Payable")          'Worksheet containing first list of references and amounts
Set ws2 = Worksheets("ABC")          'Worksheet containing second list of references and amounts
MatchEm ws1, ws2, cnRef, cnAmount, cnMatch
End Sub

Sub MatchEmLoan()
Const cnRef As String = "CUS"           'Header label. Look only for sums with the same Ref number
Const cnAmount As String = "Loan"       'Header label. Values to be summed, then compared
Const cnMatch As String = "Match_Rec"       'Header label. Sequential number for each matching combination.
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("Receivable")          'Worksheet containing first list of references and amounts
Set ws2 = Worksheets("ABC")          'Worksheet containing second list of references and amounts
MatchEm ws1, ws2, cnRef, cnAmount, cnMatch
End Sub

Sub MatchEmPayCash()
Const cnRef As String = "CUS"           'Header label. Look only for sums with the same Ref number
Const cnAmount As String = "Cash"       'Header label. Values to be summed, then compared
Const cnMatch As String = "Pay_Cash"       'Header label. Sequential number for each matching combination.
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("Payable")          'Worksheet containing first list of references and amounts
Set ws2 = Worksheets("ABC")          'Worksheet containing second list of references and amounts
MatchEm ws1, ws2, cnRef, cnAmount, cnMatch
End Sub

Sub MatchEmRecCash()
Const cnRef As String = "CUS"           'Header label. Look only for sums with the same Ref number
Const cnAmount As String = "Cash"       'Header label. Values to be summed, then compared
Const cnMatch As String = "Rec_Cash"       'Header label. Sequential number for each matching combination.
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("Receivable")          'Worksheet containing first list of references and amounts
Set ws2 = Worksheets("ABC")          'Worksheet containing second list of references and amounts
MatchEm ws1, ws2, cnRef, cnAmount, cnMatch
End Sub

Sub MatchTest()
Const cnRef As String = "Test"           'Header label. Look only for sums with the same Ref number
Const cnAmount As String = "Val"       'Header label. Values to be summed, then compared
Const cnMatch As String = "Bin"       'Header label. Sequential number for each matching combination.
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")          'Worksheet containing first list of references and amounts
Set ws2 = Worksheets("Sheet2")          'Worksheet containing second list of references and amounts
MatchEm ws1, ws2, cnRef, cnAmount, cnMatch
End Sub

Sub MatchEm(ws1 As Worksheet, ws2 As Worksheet, cnRef As String, cnAmount As String, cnMatch As String)
Dim rg1 As Range, rgRef1 As Range, rgMatch1 As Range, rgAmount1 As Range, _
    rg2 As Range, rgRef2 As Range, rgMatch2 As Range, rgAmount2 As Range
Dim dTimer As Double
Dim nCol1 As Long, nCol2 As Long, nRow1 As Long, nRow2 As Long
If ws1 Is ws2 Then
    MsgBox "The lists being tested must be on different worksheets!"
    Exit Sub
End If

dTimer = Timer
Application.ScreenUpdating = False
With ws1
    Set rg1 = .Rows(1).Find(cnRef, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    nRow1 = .Cells(.Rows.Count, rg1.Column).End(xlUp).Row
    nCol1 = .Cells(1, .Columns.Count).End(xlToLeft).Column
    Set rgRef1 = rg1.Resize(nRow1)
    Set rg1 = Range(.Cells(1, 1), .Cells(nRow1, nCol1))
    Set rgMatch1 = .Rows(1).Find(cnMatch, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Resize(nRow1)
    Set rgAmount1 = .Rows(1).Find(cnAmount, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Resize(nRow1)
End With
With ws2
    Set rg2 = .Rows(1).Find(cnRef, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    nRow2 = .Cells(.Rows.Count, rg2.Column).End(xlUp).Row
    nCol2 = .Cells(1, .Columns.Count).End(xlToLeft).Column
    Set rgRef2 = rg2.Resize(nRow2)
    Set rg2 = Range(.Cells(1, 1), .Cells(nRow2, nCol2))
    Set rgMatch2 = .Rows(1).Find(cnMatch, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).Resize(nRow2)
    Set rgAmount2 = .Rows(1).Find(cnAmount, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Resize(nRow2)
End With

NoMatchForZero rgMatch1, rgAmount1
NoMatchForZero rgMatch2, rgAmount2
OneToOne rgRef1, rgMatch1, rgAmount1, rgRef2, rgMatch2, rgAmount2
ManyToManyMatching rgRef1, rgMatch1, rgAmount1, rgRef2, rgMatch2, rgAmount2, True
ManyToManyMatching rgRef2, rgMatch2, rgAmount2, rgRef1, rgMatch1, rgAmount1, True
ManyToManyMatching rgRef1, rgMatch1, rgAmount1, rgRef2, rgMatch2, rgAmount2, False
NoMatchesHere rgMatch1
NoMatchesHere rgMatch2
SortMatches rgMatch1, rgRef1
SortMatches rgMatch2, rgRef2
Debug.Print Timer - dTimer
End Sub

Sub ClearNoSingleMatches(rgMatch As Range)
Dim cel As Range
For Each cel In rgMatch.Cells
    If cel.Value = "No single match" Then cel.ClearContents
Next
End Sub

Sub ManyToManyMatching(rgRef1 As Range, rgMatch1 As Range, rgAmount1 As Range, _
    rgRef2 As Range, rgMatch2 As Range, rgAmount2 As Range, bSingleItem As Boolean)
'Loops through the rows in worksheet1 where rgMatch1 does not have a value. Looks for matches on worksheet2. _
    Uses ManyToMany to test the sum of all the combinations of rgAmount1 items (for a given rgRef1 value) on worksheet1 _
    for matching sum of all the combinations of rgAmount2 items (for the same rgRef1 value) on worksheet2.
'For each match found, puts a sequential number in rgMatch1 and rgMatch2
'If bSingleItem is True, tests single items on worksheet1 rather than combinations
Dim i As Long, i1 As Long, i2 As Long, iNext As Long, j As Long, jMatch As Long, _
    n1 As Long, n2 As Long, nn1 As Long, nn2 As Long
Dim vmatch As Variant
Dim cel As Range, rgRef As Range
Dim rggMatch1 As Range, rggAmount1 As Range, rggMatch2 As Range, rggAmount2 As Range
Dim vAmount1 As Variant, vAmount2 As Variant
Dim vArray1 As Variant, vArray2 As Variant
ClearNoSingleMatches rgMatch1
ClearNoSingleMatches rgMatch2
SortMatches rgMatch1, rgRef1
SortMatches rgMatch2, rgRef2
n1 = rgRef1.Rows.Count
n2 = rgRef2.Rows.Count
i1 = rgMatch1.Cells(n1 + 1).End(xlUp).Row - rgMatch1.Row + 2
Do
    If i1 >= n1 Then Exit Do
    
    jMatch = Application.Max(rgMatch1)
    Set rgRef = Range(rgRef1.Cells(i1, 1), rgRef1.Cells(n1, 1))
    nn1 = Application.CountIf(rgRef, rgRef.Cells(1, 1).Value)
    iNext = i1 + nn1    'Index number of next Ref
    ReDim vArray1(1 To nn1)
    Set rggMatch1 = rgMatch1.Cells(i1, 1).Resize(nn1)
    vAmount1 = rgAmount1.Cells(i1, 1).Resize(nn1).Value
    
    i2 = rgMatch2.Cells(n2 + 1).End(xlUp).Row - rgMatch2.Row + 2
    Set rgRef = Range(rgRef2.Cells(i2, 1), rgRef2.Cells(n2, 1))
    vmatch = Application.Match(rgRef1.Cells(i1, 1).Value, rgRef, 0)
    If Not IsError(vmatch) Then
        Set rgRef = Range(rgRef.Cells(vmatch, 1), rgRef2.Cells(n2, 1))
        nn2 = Application.CountIf(rgRef, rgRef.Cells(1, 1).Value)
        ReDim vArray2(1 To nn2)
        Set rggMatch2 = rgMatch2.Cells(rgRef.Row, 1).Resize(nn2)
        vAmount2 = rgAmount2.Cells(rgRef.Row, 1).Resize(nn2).Value
        If ManyToMany(vAmount1, vArray1, vAmount2, vArray2, bSingleItem) Then
            jMatch = jMatch + 1
            UpdateMatches vArray1, rggMatch1, jMatch
            UpdateMatches vArray2, rggMatch2, jMatch
            SortMatches rgMatch1, rgRef1
            SortMatches rgMatch2, rgRef2
            i1 = i1 + Application.Sum(vArray1)
        Else
            i1 = iNext
        End If
    Else
        i1 = iNext
    End If
Loop
End Sub

Sub NoMatchForZero(rgMatch As Range, rgAmount As Range)
Dim i As Long, n As Long
n = rgAmount.Rows.Count
For i = 1 To n
    If rgAmount.Cells(i, 1).Value = 0 Then rgMatch.Cells(i, 1).Value = "No match"
Next
End Sub

Sub NoMatchesHere(rgMatch As Range)
Dim cel As Range
For Each cel In rgMatch.Cells
    If cel.Value = 0 Then cel.Value = "No match"
Next
End Sub

Sub OneToOne(rgRef1 As Range, rgMatch1 As Range, rgAmount1 As Range, rgRef2 As Range, rgMatch2 As Range, rgAmount2 As Range)
Dim i As Long, i1 As Long, i2 As Long, j As Long, jMatch As Long, n As Long, n1 As Long, n2 As Long
Dim vmatch As Variant
Dim rg As Range, rgAmount As Range, rgRef As Range, rgMatch As Range
Dim dAmount As Double
SortMatches rgMatch1, rgRef1
SortMatches rgMatch2, rgRef2
n1 = rgRef1.Rows.Count
n2 = rgRef2.Rows.Count
i1 = rgMatch1.Cells(n1 + 1).End(xlUp).Row - rgMatch1.Row + 2
i2 = rgMatch2.Cells(n2 + 1).End(xlUp).Row - rgMatch2.Row + 2
jMatch = Application.Max(rgMatch1)
Set rgRef = Range(rgRef2.Cells(i2, 1), rgRef2.Cells(n2, 1))
For i = i1 To n1
    vmatch = Application.Match(rgRef1.Cells(i, 1).Value, rgRef, 0)
    If Not IsError(vmatch) Then
        dAmount = rgAmount1.Cells(i, 1).Value
        Set rg = rgRef.Cells(vmatch, 1)
        n = Application.CountIf(Range(rg, rgRef2.Cells(n2, 1)), rgRef1.Cells(i, 1).Value)
        Set rg = rg.Resize(n)
        Set rgAmount = Intersect(rgAmount2, rg.EntireRow)
        Set rgMatch = Intersect(rgMatch2, rg.EntireRow)
        For j = 1 To n
            If rgAmount.Cells(j, 1) = dAmount And rgMatch.Cells(j, 1) = "" Then
                jMatch = jMatch + 1
                rgMatch.Cells(j, 1) = jMatch
                rgMatch1.Cells(i, 1) = jMatch
                Exit For
            End If
        Next
    End If
Next
End Sub

Sub SortMatches(rgMatch As Range, rgRef As Range)
'Sort the data first by Match column and then by Ref
Dim rg As Range
With rgMatch.Worksheet
    Set rg = .Cells(1, .Columns.Count).End(xlToLeft)      'Rightmost header label
    Set rg = .Range(.Cells(1, 1), rg.Cells(rgRef.Rows.Count, 1))
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=rgMatch.Offset(1, 0).Resize(rg.Rows.Count - 1), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Sort.SortFields.Add Key:=rgRef.Offset(1, 0).Resize(rg.Rows.Count - 1), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange rg
        .Header = xlYes
        .MatchCase = False
        .Apply
    End With
End With
End Sub

Sub UpdateMatches(varray As Variant, rgMatch As Range, jMatch As Long)
Dim i As Long
For i = UBound(varray) To 1 Step -1
    If varray(i) = 1 Then rgMatch.Cells(i, 1).Value = jMatch
Next
End Sub

Function ManyToMany(Amount1 As Variant, Match1 As Variant, Amount2 As Variant, Match2 As Variant, bSingleItem As Boolean) As Boolean
'Returns True if the sum of a combination of Amount1 values equals the sum of a combination of Amount2 values
'If bSingleItem is True, then compare combinations of Amount2 to individual items chosen from Amount1
'The array elements in Match1 and Match2 will be 1 if an item is included in the sum, or zero otherwise
'Function stops at first pair of combinations whose sums match
Dim iCount1 As Long, iCount2 As Long, i1 As Long, i2 As Long, n1 As Long, n2 As Long
Dim dCriteria As Double, d1 As Double, d2 As Double
Dim b1 As Boolean, b2 As Boolean
n1 = UBound(Match1)
n2 = UBound(Match2)
For i1 = 1 To n1
    Match1(i1) = 0
Next
iCount1 = 2
Do
    If bSingleItem Or (n1 = 1) Then
        b1 = NextCombination(Match1, bSingleItem)
    Else
        b1 = NextComboOfN(Match1, iCount1)
    End If
    If b1 = True Then
        For iCount2 = 2 To MaxItems
            d1 = IIf(n1 = 1, Amount1, SumIff(Match1, Amount1))
            For i2 = 1 To n2
                Match2(i2) = 0
            Next
            Do
                If n2 = 1 Then
                    b2 = NextCombination(Match2, False)
                Else
                    b2 = NextComboOfN(Match2, iCount2)
                End If
                If b2 = True Then
                    d2 = IIf(n2 = 1, Amount2, SumIff(Match2, Amount2))
                    If Abs(d1 - d2) < cnPrecision Then
                        ManyToMany = True
                        Exit Function
                    End If
                End If
            Loop While b2 = True
            If n2 <= iCount2 Then Exit For
        Next
    End If
    If b1 = False Then iCount1 = iCount1 + 1
    If (iCount1 > MaxItems) Or (n1 < iCount1) Then Exit Do
    If (bSingleItem = True) And (b1 = False) Then Exit Do
Loop
ManyToMany = False
End Function

Function NextCombination(varray As Variant, bSingleItem As Boolean) As Boolean
'Increments vArray by 1 as through it were a binary number. Least significant bit is first element in vArray.
'Function returns TRUE if a valid combination is returned, and FALSE if all the combinations have been cycled through
'Function returns only single items if bSingleItem is TRUE. It skips single items if bSingleItem is FALSE
Dim i As Long, ii As Long, n As Long
Dim bCarry As Boolean
ii = LBound(varray)
n = UBound(varray)
If Application.Sum(varray) = 0 Then
    For i = ii To n
        varray(i) = 0
    Next
    If bSingleItem Then
        varray(ii) = 1
        NextCombination = True
        Exit Function
    End If
End If

If bSingleItem Then
    For i = ii To n
        If varray(i) = 1 Then
            varray(i) = 0
            If i <> n Then varray(i + 1) = 1
            NextCombination = (i <> n)
            Exit Function
        End If
    Next
Else
    bCarry = True
    Do
        For i = ii To n
            If bCarry = True Then
                If varray(i) = 0 Then
                    varray(i) = 1
                    bCarry = False
                Else
                    varray(i) = 0
                End If
            End If
        Next
        If bCarry = True Then
            Exit Do
        Else
            If Application.Sum(varray) < 2 Then
                bCarry = True
            Else
                Exit Do
            End If
        End If
    Loop
End If
NextCombination = Not bCarry
End Function

Function NextComboOfN(varray As Variant, nItems As Long) As Boolean
'Increments vArray by 1 as through it were a binary number. Least significant bit is first element in vArray. _
    Each combination will contain exactly nItems _
    nItems must be 2 or more
'Function returns TRUE if a valid combination is returned, and FALSE if all the combinations have been cycled through
Dim i As Long, ii As Long, j As Long, jCount As Long, jNth As Long, n As Long
Dim bCarry As Boolean
ii = LBound(varray)
n = UBound(varray)
If (n + 1 - ii) < nItems Then
    NextComboOfN = False
    Exit Function
End If

If Application.Sum(varray) = 0 Then
    For i = nItems - 1 + ii To ii Step -1
        varray(i) = 1
    Next
    If nItems < n Then
        For i = nItems + 1 To n
            varray(i) = 0
        Next
    End If
    NextComboOfN = True
    Exit Function
End If

bCarry = True
Do
    jCount = 0
    For i = ii To n
        If bCarry = False Then Exit For
        If varray(i) = 0 Then
            varray(i) = 1
            bCarry = False
            Exit For
        Else
            varray(i) = 0
        End If
    Next
    If bCarry = True Then Exit Do
    
    For i = n To ii Step -1
        If varray(i) = 1 Then jCount = jCount + 1
        If jCount = nItems Then
            jNth = i
            If (varray(ii) = 0) Or (jNth = ii) Then Exit Do
            For j = jNth - 2 + ii To ii Step -1
                varray(j) = 1
            Next
            Exit For
        End If
    Next
    bCarry = True
Loop
NextComboOfN = Not bCarry
End Function

Function SumIff(varray As Variant, Amount As Variant) As Double
Dim d As Double
Dim i As Long
Dim v As Variant
If IsArray(Amount) = False Then
    d = Amount
Else
    For Each v In varray
        i = i + 1
        If v = 1 Then d = d + Amount(i, 1)
    Next
End If
SumIff = d
End Function

Select allOpen in new window

JKTestQ28378136x.xlsm

Hi Brad

you have done a brilliant job thanks. Unfortunately I am getting an error when I run
MatchEmPayCash() and MatchEmRecCash.

Object variable or With block variable not set

on this line

Set rgAmount2 = .Rows(1).Find(cnAmount, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Resize(nRow2)

I have stepped through the code but cannot figure out what the problem is.
I am sure it's somthing but I need your help [again].

Thanks

John,
I can reproduce the error, but absolutely don't understand it. The Find method ought to be working in that situation.

I decided to use the MATCH function as a workaround. Only the MatchEm sub needed changing.

Brad

Sub MatchEm(ws1 As Worksheet, ws2 As Worksheet, cnRef As String, cnAmount As String, cnMatch As String)
Dim rg1 As Range, rgRef1 As Range, rgMatch1 As Range, rgAmount1 As Range, _
    rg2 As Range, rgRef2 As Range, rgMatch2 As Range, rgAmount2 As Range
Dim dTimer As Double
Dim nCol1 As Long, nCol2 As Long, nRow1 As Long, nRow2 As Long
Dim v As Variant
If ws1 Is ws2 Then
    MsgBox "The lists being tested must be on different worksheets!"
    Exit Sub
End If

dTimer = Timer
Application.ScreenUpdating = False
With ws1
    Set rg1 = .Rows(1).Find(cnRef, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    nRow1 = .Cells(.Rows.Count, rg1.Column).End(xlUp).Row
    nCol1 = .Cells(1, .Columns.Count).End(xlToLeft).Column
    Set rgRef1 = rg1.Resize(nRow1)
    Set rg1 = Range(.Cells(1, 1), .Cells(nRow1, nCol1))
    
    v = Application.Match(cnMatch, .Rows(1), 0)
    If IsError(v) Then
        MsgBox "Couldn't find " & cnMatch & " on worksheet " & ws1.Name
        Exit Sub
    End If
    Set rgMatch1 = .Cells(1, v).Resize(nRow1)
    'Set rgMatch1 = .Rows(1).Find(cnMatch, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Resize(nRow1)
    
    v = Application.Match(cnAmount, .Rows(1), 0)
    If IsError(v) Then
        MsgBox "Couldn't find " & cnAmount & " on worksheet " & ws1.Name
        Exit Sub
    End If
    Set rgAmount1 = .Cells(1, v).Resize(nRow1)
    'Set rgAmount1 = .Rows(1).Find(cnAmount, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Resize(nRow1)
End With
With ws2
    Set rg2 = .Rows(1).Find(cnRef, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    nRow2 = .Cells(.Rows.Count, rg2.Column).End(xlUp).Row
    nCol2 = .Cells(1, .Columns.Count).End(xlToLeft).Column
    Set rgRef2 = rg2.Resize(nRow2)
    Set rg2 = Range(.Cells(1, 1), .Cells(nRow2, nCol2))
    
    v = Application.Match(cnMatch & "*", .Rows(1), 0)
    If IsError(v) Then
        MsgBox "Couldn't find " & cnMatch & " on worksheet " & ws2.Name
        Exit Sub
    End If
    Set rgMatch2 = .Cells(1, v).Resize(nRow2)
    'Set rgMatch2 = .Rows(1).Find(cnMatch, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).Resize(nRow2)
    
    v = Application.Match(cnAmount, .Rows(1), 0)
    If IsError(v) Then
        MsgBox "Couldn't find " & cnAmount & " on worksheet " & ws2.Name
        Exit Sub
    End If
    Set rgAmount2 = .Cells(1, v).Resize(nRow2)
    'Set rgAmount2 = .Rows(1).Find(cnAmount, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False).Resize(nRow2)
End With

NoMatchForZero rgMatch1, rgAmount1
NoMatchForZero rgMatch2, rgAmount2
OneToOne rgRef1, rgMatch1, rgAmount1, rgRef2, rgMatch2, rgAmount2
ManyToManyMatching rgRef1, rgMatch1, rgAmount1, rgRef2, rgMatch2, rgAmount2, True
ManyToManyMatching rgRef2, rgMatch2, rgAmount2, rgRef1, rgMatch1, rgAmount1, True
ManyToManyMatching rgRef1, rgMatch1, rgAmount1, rgRef2, rgMatch2, rgAmount2, False
NoMatchesHere rgMatch1
NoMatchesHere rgMatch2
SortMatches rgMatch1, rgRef1
SortMatches rgMatch2, rgRef2
Debug.Print Timer - dTimer
End Sub

Select allOpen in new window

JKTestQ28378136x.xlsm

Brad,

Brilliant thank you so much for the time and effort you put into this it works perfectly now.

Kind Regards
John