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
MatchV3.1Q28378136.xlsm
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
MatchV3.1Q28378136.xlsm
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" 'Header label. Sequential number for each matching combination.
Const cnPrecision As Double = 0.001 'Sums must match within this amount
Sub MatchEm()
Dim ws1 As Worksheet, ws2 As Worksheet
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
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
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:=xlPart, 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 + vmatch - 1, 1).Resize(nn2)
vAmount2 = rgAmount2.Cells(rgRef.Row + vmatch - 1, 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(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 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 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
Do
b1 = NextCombination(Match1, bSingleItem)
If b1 = True Then
d1 = IIf(n1 = 1, Amount1, SumIff(Match1, Amount1))
For i2 = 1 To n2
Match2(i2) = 0
Next
Do
b2 = NextCombination(Match2, False)
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
End If
Loop While b1 = True
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 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
MatchV3.1Q28378136-3.xlsm
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.
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
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
BradConst 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
JKTestQ28378136x.xlsm
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
JKTestQ28378136x.xlsm
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
why excel offset of negative and positive shows incorrect Delta, please see attached | 2 | 17 | |
Remove duplicates using cell values VBA | 2 | 32 | |
Importing contacts into Office 365 Outlook | 12 | 39 | |
vba delete dups is not working | 35 | 15 |
Join the community of 500,000 technology professionals and ask your questions.