VBA匹配2组数据
我在这里有这个问题。 我想匹配并突出显示表1和表2中的这两个数据。标准是合同代码必须匹配，所以合同代码的总和数量也应该在表2中。
例如在表1中， ZBZ8 375应与表2上的三个数据条目匹配并加ZBZ8 375显示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很新，请耐心等待。 正如Thomas下面提到的那样，出现Dictionary就是要这样做的呢？
我已经尝试了下面的答案的代码，但似乎没有工作。
这是一个使用评论中build议的字典的例子。
我已经包含了几个循环，以突出显示源行和总行，其中不存在按代码将个别行匹配到总和。
这是基于你的数据被设置为每个图像如下：
总数来validation：
总结：
请注意，在这种情况下，只有TYZ7C被突出显示。 它实际上只存在于一张表格中，而不存在于另一张表格中（没有检查的金额）。 总数匹配其他人。 您可以考虑使用不同的颜色突出显示丢失的代码。
负数的红色字体是由于已经应用的格式的types，与代码的作用无关。
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 eg "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 eg 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
你的代码使用数组实际上看起来像一个体面的开始。
以下是我将如何解决它：
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，…variablesreplace为数据集启动位置的实际值即可。