匹配2组数据，2个要求

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很新，请耐心等待我。我做了一些研究，看起来字典是解决这个问题的方法吗？

我已经获得了以下代码，但似乎它不起作用。

Public Sub CheckTotal()

    Dim wb As Workbook
    Dim ws As Worksheet

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

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

    Set totalsDict = New Scripting.Dictionary

    Dim valuesArr()
    Dim valuesSource As Range

    Set valuesSource = ws.Range("A2:B6")         'range containing values to sum
    valuesArr = valuesSource.Value

    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

    Dim currCell As Range
    Dim loopRange As Range

    Set loopRange = ws.Range("D2:D3")            'range containing codes whose sums are to be checked

    Dim colourCodesArr()
    ReDim colourCodesArr(0 To loopRange.Rows.Count)
    Dim counter As Long
    counter = 0

    For Each currCell In loopRange.Cells

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

            currCell.Offset(, 1).Font.ColorIndex = xlAutomatic

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

            counter = counter + 1

        Else

            currCell.Offset(, 1).Font.Color = vbRed

        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 red

            currCell.Offset(, -1).Font.Color = vbRed

        Else

            currCell.Offset(, -1).Font.ColorIndex = xlAutomatic

        End If

    Next currCell

End Sub