Excel VBA – 匹配两个列表。 如果有任何总和组合匹配，请突出显示匹配的项目
我一直在寻找一个很好的工具来匹配大的值列表到另一个列表 – find总结匹配的所有值。 到目前为止，我发现的最好的工具是http://www.tushar-mehta.com/excel/templates/match_values/
我已经列出了我从Tushar-Mehta的代码中得到的代码hackjob，并且find了如何提高速度或更好的工具的想法。 我对这个代码的工作原理有一个非常有限的理解，但是这里尽我所能。 任何帮助或澄清真正赞赏。 谢谢！
Option Explicit Function RealEqual(a, B, Optional Epsilon As Double = 0.00000001) RealEqual = Abs(a - B) <= Epsilon End Function Function ExtendRslt(CurrRslt, NewVal, Separator) If CurrRslt = "" Then ExtendRslt = NewVal _ Else ExtendRslt = CurrRslt & Separator & NewVal End Function Sub recursiveMatch(ByVal MaxSoln As Integer, ByVal TargetVal, InArr(), _ ByVal HaveRandomNegatives As Boolean, _ ByVal CurrIdx As Integer, _ ByVal CurrTotal, ByVal Epsilon As Double, _ ByRef Rslt(), ByVal CurrRslt As String, ByVal Separator As String) Dim i As Integer For i = CurrIdx To UBound(InArr) If RealEqual(CurrTotal + InArr(i), TargetVal, Epsilon) Then Rslt(UBound(Rslt)) = ExtendRslt(CurrRslt, i, Separator) If MaxSoln = 0 Then If UBound(Rslt) Mod 100 = 0 Then Debug.Print "Rslt(" & UBound(Rslt) & ")=" & Rslt(UBound(Rslt)) Else If UBound(Rslt) >= MaxSoln Then Exit Sub End If ReDim Preserve Rslt(UBound(Rslt) + 1) ElseIf IIf(HaveRandomNegatives, False, CurrTotal + InArr(i) > TargetVal + Epsilon) Then ElseIf CurrIdx < UBound(InArr) Then recursiveMatch MaxSoln, TargetVal, InArr(), HaveRandomNegatives, _ i + 1, _ CurrTotal + InArr(i), Epsilon, Rslt(), _ ExtendRslt(CurrRslt, i, Separator), _ Separator If MaxSoln <> 0 Then If UBound(Rslt) >= MaxSoln Then Exit Sub Else 'we've run out of possible elements and we _ still don't have a match End If Next i End Sub Function ArrLen(Arr()) As Integer On Error Resume Next ArrLen = UBound(Arr) - LBound(Arr) + 1 End Function Function checkRandomNegatives(Arr) As Boolean Dim i As Long i = LBound(Arr) Do While Arr(i) < 0 And i < UBound(Arr): i = i + 1: Loop If i = UBound(Arr) Then Exit Function Do While Arr(i) >= 0 And i < UBound(Arr): i = i + 1: Loop checkRandomNegatives = Arr(i) < 0 End Function Sub startSearch() 'The selection should be a single contiguous range in a single column. _ The first cell indicates the number of solutions wanted. Specify zero for all. _ The 2nd cell is the target value. _ The rest of the cells are the values available for matching. _ The output is in the column adjacent to the one containing the input data. Range("G1").Select Range(Selection, Selection.End(xlDown)).Select If Not TypeOf Selection Is Range Then GoTo ErrXIT If Selection.Areas.count > 1 Or Selection.Columns.count > 1 Then GoTo ErrXIT If Selection.Rows.count < 3 Then GoTo ErrXIT Dim TargetVal, Rslt(), InArr(), StartTime As Date, MaxSoln As Integer, _ HaveRandomNegatives As Boolean StartTime = Now() 'Set desired number of results zero being all '////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// MaxSoln = Cells(5, 2).Value 'Set value to be matched '////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// TargetVal = Cells(3, 2).Value InArr = Application.WorksheetFunction.Transpose( _ Selection.Offset(0, 0).Resize(Selection.Rows.count - 0).Value) HaveRandomNegatives = checkRandomNegatives(InArr) If Not HaveRandomNegatives Then ElseIf MsgBox("At least 1 negative number is present between positive numbers" _ & vbNewLine _ & "It may take a lot longer to search for matches." & vbNewLine _ & "OK to continue else Cancel", vbOKCancel) = vbCancel Then Exit Sub End If ReDim Rslt(0) recursiveMatch MaxSoln, TargetVal, InArr, HaveRandomNegatives, _ LBound(InArr), 0, 0.00000001, _ Rslt, "", "," 'This only assigns the time taken to run '////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// 'Rslt(UBound(Rslt)) = "" 'Format(Now, "hh:mm:ss") 'ReDim Preserve Rslt(UBound(Rslt) + 1) 'Rslt(UBound(Rslt)) = "" 'Format(StartTime, "hh:mm:ss") '////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// Range("d2").Value = _ Application.WorksheetFunction.Transpose(Rslt) Range("g:g").ClearFormats SplitText addcolor Range("D2").ClearContents Range("q:q").ClearContents Exit Sub ErrXIT: MsgBox "Please select cells in a single column before using this macro" & vbNewLine _ & "The selection should be a single contiguous range in a single column." & vbNewLine _ & "The first cell indicates the number of solutions wanted. Specify zero for all." & vbNewLine _ & "The 2nd cell is the target value." & vbNewLine _ & "The rest of the cells are the values available for matching." & vbNewLine _ & "The output is in the column adjacent to the one containing the input data." End Sub 我看不到你的名单来自哪里。 这可以通过条件格式来完成，但是这里是一个快速的macros，可以修改它来比较你的列表，无论你在哪里数据来自任何你想要的，当你在第二个列表中find一个匹配。
这只是一个窗体上的button背后的代码，但你可以把它变成一个函数或任何你需要的。
您将需要引用“Microsoft ActiveX数据对象2.8库”。 在你的vba工作室里的工具菜单 – >参考。 你可以在那里find它。
Option Explicit Private Sub CommandButton1_Click() Dim rs As New ADODB.Recordset Dim ws As Excel.Worksheet Dim lRow As Long Dim iSum As Integer 'Get your sum from a message box or where ever. iSum = 12 Set ws = Application.ActiveSheet 'Add fields to your recordset for storing data. You can store sums here. With rs .Fields.Append "Row", adInteger .Fields.Append "Column1", adInteger .Fields.Append "Column2", adInteger .Open End With lRow = 1 'Loop through and record what is in the columns to compare. Do While lRow <= ws.UsedRange.Rows.Count rs.AddNew rs.Fields("Row").Value = lRow rs.Fields("Column1").Value = ws.Range("A" & lRow).Value rs.Fields("Column2").Value = ws.Range("B" & lRow).Value rs.Update lRow = lRow + 1 ws.Range("A" & lRow).Activate Loop If rs.EOF = False Then rs.MoveFirst End If 'Now go through and check the values of the second column against what we recorded from the first 'lRow = 1 'Do While lRow <= ws.UsedRange.Rows.Count 'rs.Filter = "" 'rs.Filter = "Column1='" & ws.Range("B" & lRow).Value & "'" 'If we have a match, turn it red. 'If rs.RecordCount > 0 Then ' ws.Range("B" & lRow).Font.ColorIndex = 3 'End If 'lRow = lRow + 1 'ws.Range("A" & lRow).Activate 'Loop 'Here we look if the sum of the two fields eqaul what we are looking for Do While rs.EOF = False If (rs.Fields("Column1") + rs.Fields("Column2")) = iSum Then ws.Range("A" & rs.Fields("Row")).Font.ColorIndex = 3 ws.Range("B" & rs.Fields("Row")).Font.ColorIndex = 3 End If rs.MoveNext Loop End Sub