Question

我有这个问题。我想匹配并突出显示表1和表2中的这两个数据。标准是合同代码必须匹配，因此表2中该合同代码的总数量也应该匹配。

例如，在表1中，ZBZ8 375应与表2 50 ZBZ8 125 ZBZ8 200 ZBZ8上的三个数据条目匹配并突出显示。

Table 1    
CONTRACT    LOTS
    ZBZ8        375 
    ZBU8        339 
    ZBM8       -250 
    ZBH8        -75 
Table 2
    Qty    Contract
    40      TYZ7
    200     TYZ7C
    -400    TYZ7C
    100     EDZ7
    100     EDZ7
    100     EDZ7
    100     EDH8
    -100    EDZ8
    -100    EDZ8
    -100    EDH9
    -25     ZBH8
    -50     ZBH8
    -250    ZBM8
    114     ZBU8
    200     ZBU8
    25      ZBU8
    50      ZBZ8
    125     ZBZ8
    200     ZBZ8
    25      XMZ7
    -115    YMZ7
    -200    YMZ7

我对VBA很新，请耐心等待我。正如托马斯在下面提到过的那样，看起来字典是解决这个问题的方法吗？

我已经尝试过以下答案中的代码，但它似乎没有用。

Answer 1

以下是使用评论中建议的字典的示例。

我已经包含了几个循环来突出显示源行和总行数，而不是按代码匹配各行的总和。

这是基于您按照图像设置的数据，如下所示：

总计验证：

总和的行：

请注意，在这种情况下，只突出显示TYZ7C。它实际上只存在于一张纸而不存在于另一张纸中（没有要检查的金额）。总数与其他人匹配。您可以考虑使用不同的颜色突出显示缺失的代码。

负数的红色字体是由于已应用的格式类型而与代码的作用无关。

Option Explicit
'Tools > References > Add reference to Microsoft Scripting Runtime

Public Sub CheckTotal()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim ws1 As Worksheet

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Futures - DB")       ' change as appropriate e.g. "Futures - DB"
    Set ws1 = wb.Worksheets("Futures - FNZC")

    Dim totalsDict As Scripting.Dictionary       'set reference to microsoft scripting runtime

    Set totalsDict = New Scripting.Dictionary

    Dim valuesArr()
    Dim valuesSource As Range

    Dim lastRowInM As Long

    lastRowInM = ws.Cells(ws.Rows.Count, "M").End(xlUp).Row

    Set valuesSource = ws.Range("M3:N" & lastRowInM) 'range containing values to sum

    valuesSource.Cells.Interior.PatternColorIndex = xlAutomatic

    valuesArr = valuesSource.Value

    AddToDict valuesArr, totalsDict

    ' PrintDict totalsDict

    Dim currCell As Range
    Dim loopRange As Range

    Set loopRange = ws1.Range("C9:D37")          'range containing codes whose sums are to be checked

    loopRange.Cells.Interior.PatternColorIndex = xlAutomatic

    Dim colourCodesArr()
    ReDim colourCodesArr(0 To 1000)              'change this number to a number greater than the expected number of totals to be checked.

    Dim counter As Long
    counter = 0

    For Each currCell In loopRange.Columns(1).Rows

        If Not IsEmpty(currCell) And currCell <> "CONTRACT" Then 'ignore cells in range that don't qualify for consideration

            If currCell.Offset(, 1) = totalsDict(currCell.Value2) Then

                colourCodesArr(counter) = currCell 'store codes whose totals match summing of rows match in array

                counter = counter + 1

            Else

                currCell.Offset(, 1).Interior.ColorIndex = 6 'colour yellow

            End If

        End If

    Next currCell

    ReDim Preserve colourCodesArr(0 To counter - 1)

    For Each currCell In valuesSource.Columns(2).Rows 'Loop the codes in the source range checking if a no match was registered

        If UBound(Filter(colourCodesArr, currCell.Value2)) = -1 Then 'if code not found in array highlight in yellow

            currCell.Offset(, -1).Interior.ColorIndex = 6

        End If

    Next currCell

End Sub

Private Sub AddToDict(ByVal valuesArr As Variant, ByRef totalsDict As Dictionary)

    Dim code As Long

    For code = LBound(valuesArr, 1) To UBound(valuesArr, 1)

        If totalsDict.Exists(valuesArr(code, 2)) Then 'if code exists add new value to existing value otherwise add code and value to the dictionary e.g. TYZ7C ,200


            totalsDict(valuesArr(code, 2)) = totalsDict(valuesArr(code, 2)) + valuesArr(code, 1)

        Else

            totalsDict.Add valuesArr(code, 2), valuesArr(code, 1)

        End If

    Next code

End Sub

Private Sub PrintDict(ByVal totalsDict As Dictionary)

    Dim key As Variant

    For Each key In totalsDict.Keys
        Debug.Print "Key: " & key & " Value: " & totalsDict(key)
    Next
End Sub

Answer 2

使用数组的代码实际上看起来不错。

以下是我将如何解决它：

Dim x AS Long, y AS Long
For x = DATA2_STARTING_ROW to 0 ' infinite loop (through data set 2)
    Dim code AS String
    code = Cells(x, DATA2_CODE_COLUMN)
    If code = "" Then Exit For ' no more data

    Dim total AS Integer
    total = 0
    For y = DATA1_STARTING_ROW to 0 ' (through data set 1)
        If Cells(y, DATA1_CODE_COLUMN) = "" Then Exit For
        If Cells(y, DATA1_CODE_COLUMN) = code Then ' found a match
            total = total + Cells(y, DATA1_QUANTITY_COLUMN)
        End If
    Next
    If total = Cells(x, DATA2_QUANTITY_COLUMN) Then ' the totals match
        Cells(x, DATA2_QUANTITY_COLUMN).Interior.Color = RGB(50, 100, 50)
        Cells(x, DATA2_CODE_COLUMN).Interior.Color = RGB(50, 100, 50)
    End If
Next

只需将DATA2_QUANTITY_COLUMN，...变量替换为数据集开始位置的实际值。

VBA匹配2组数据

2 个答案: