Question

我一直在寻找一个很好的工具来将大型值列表与另一个列表匹配 - 找到所有值相加的值。到目前为止，我发现的最好的工具来自 http://www.tushar-mehta.com/excel/templates/match_values/

我已经列出了我从Tushar-Mehta代码中获取的代码的hackjob，并找到了如何提高速度或更好工具的想法。我对这段代码的工作方式的了解非常有限，但我能尽我所能。任何帮助或澄清都是真正的赞赏。谢谢！

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

Answer 1

我看不到你的名单来自哪里。这可以通过条件格式化完成，但这里有一个快速宏，可以修改它来比较您的数据来自哪里的列表，并在第二个列表中找到匹配时执行任何操作。

这只是表单上按钮背后的代码，但您可以将其转换为函数或任何您需要的函数。

您需要引用“Microsoft ActiveX Data Objects 2.8库”。在工具菜单上的vba工作室中 - ＆gt;引用。你可以在那里找到它。

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

Excel VBA - 匹配两个列表。如果任何总和组合匹配，请突出显示匹配的项目

1 个答案: