使用Scripting Dictionary区分重复货柜并关联表格数据问题

问题背景 #

尝试通过货柜号关联两个表格，但货柜号会在三个月后重复，导致数量被错误合并：

• Table1（Tbl1）：包含货柜号（Container）、处理日期（ProcessDate）
• Table2（Tbl2）：包含货柜号（Container）、分配数量（AllocatedQty）、发票数量（InvoiceQty）、发票日期（InvoiceDate）

计划通过处理日期与发票日期差值≤30天来匹配对应数据（因货柜至少三个月才重复），用Scripting Dictionary存储Table2数据后遍历Table1匹配，但现有VBA代码仅捕获一行数据，未对多行数量正确汇总。

原VBA代码 #

Sub joinTables()

Dim wLo As ListObject
Dim cLo As ListObject
Set wLo = wmsWks.ListObjects("Tbl2")
Set cLo = clincWks.ListObjects("Tbl1")

Dim containerDict As Object
Set containerDict = CreateObject("Scripting.Dictionary")

'fill the dictionary with WMS data, summing qty
Dim i As Long
For i = 1 To wLo.ListRows.Count
    Container = wLo.ListColumns("Container").DataBodyRange(i).Value
    allocQty = wLo.ListColumns("AllocatedQty").DataBodyRange(i).Value
    invQty = wLo.ListColumns("InvoiceQty").DataBodyRange(i).Value
    invDate = wLo.ListColumns("InvoiceDate").DataBodyRange(i).Value

    If containerDict.exists(Container) Then
        containerDict(Container)(0) = containerDict(Container)(0) + allocQty
        containerDict(Container)(1) = containerDict(Container)(1) + invQty
    Else
        containerDict(Container) = Array(allocQty, invQty, invDate)
    End If
    
Next i
    
'headers
joinWks.Cells(1, 1).Value = "Container"
joinWks.Cells(1, 2).Value = "AllocatedQty"
joinWks.Cells(1, 3).Value = "InvoicedQty"
joinWks.Cells(1, 4).Value = "InvoiceDate"
joinWks.Cells(1, 5).Value = "ProcessDate"

'loop through clinc data
For i = 1 To cLo.ListRows.Count
    Container = cLo.ListColumns("Container").DataBodyRange(i).Value
    procDate = cLo.ListColumns("Process Date").DataBodyRange(i).Value

    If containerDict.exists(Container) Then
        allocQty = containerDict(Container)(0)
        invQty = containerDict(Container)(1)
        invDate = containerDict(Container)(2)
      
        'check date difference within 30 days
        If Abs(procDate - invDate) <= 30 Then
            j = joinWks.Cells(joinWks.Rows.Count, "A").End(xlUp).Row + 1
            joinWks.Cells(j, 1).Value = Container
            joinWks.Cells(j, 2).Value = allocQty
            joinWks.Cells(j, 3).Value = invQty
            joinWks.Cells(j, 4).Value = crDate
            joinWks.Cells(j, 5).Value = procDate
        End If
    End If
Next i

Set containerDict = Nothing

End Sub

问题根源 #

1. 字典存储逻辑错误：原代码用货柜号作为唯一键直接累加数量，但同一货柜号可能对应多个不同发票日期的记录，直接合并会导致后续日期匹配无法区分。
2. 日期匹配逻辑缺失多行处理：仅存储每个货柜号的一组汇总数据，无法匹配Table1中同一货柜号对应的不同处理日期记录，也无法对符合条件的多行数据单独汇总。
3. 变量错误：代码中crDate未定义，应为invDate。

修正后的VBA代码 #

Sub joinTables()
    Dim wLo As ListObject, cLo As ListObject
    Set wLo = wmsWks.ListObjects("Tbl2")
    Set cLo = clincWks.ListObjects("Tbl1")
    
    ' 字典存储：键为货柜号，值为该货柜号的所有记录数组（含数量和日期）
    Dim containerDict As Object
    Set containerDict = CreateObject("Scripting.Dictionary")
    
    ' 填充字典：保留同一货柜号的所有原始记录
    Dim i As Long
    For i = 1 To wLo.ListRows.Count
        Dim containerKey As String
        containerKey = wLo.ListColumns("Container").DataBodyRange(i).Value
        
        Dim recordData As Variant
        recordData = Array(wLo.ListColumns("AllocatedQty").DataBodyRange(i).Value, _
                          wLo.ListColumns("InvoiceQty").DataBodyRange(i).Value, _
                          wLo.ListColumns("InvoiceDate").DataBodyRange(i).Value)
        
        If containerDict.exists(containerKey) Then
            ' 追加新记录到已有货柜号的数组中
            Dim existingRecords As Variant
            existingRecords = containerDict(containerKey)
            ReDim Preserve existingRecords(UBound(existingRecords) + 1)
            existingRecords(UBound(existingRecords)) = recordData
            containerDict(containerKey) = existingRecords
        Else
            ' 首次出现货柜号，初始化记录数组
            containerDict(containerKey) = Array(recordData)
        End If
    Next i
    
    ' 写入结果表头
    With joinWks
        .Cells(1, 1).Value = "Container"
        .Cells(1, 2).Value = "AllocatedQty"
        .Cells(1, 3).Value = "InvoicedQty"
        .Cells(1, 4).Value = "InvoiceDate"
        .Cells(1, 5).Value = "ProcessDate"
    End With
    
    ' 遍历Table1，匹配符合日期条件的记录并汇总
    Dim j As Long
    j = 2 ' 从第2行开始写入数据
    For i = 1 To cLo.ListRows.Count
        Dim currentContainer As String
        currentContainer = cLo.ListColumns("Container").DataBodyRange(i).Value
        Dim currentProcDate As Date
        currentProcDate = cLo.ListColumns("Process Date").DataBodyRange(i).Value
        
        If containerDict.exists(currentContainer) Then
            Dim allRecords As Variant
            allRecords = containerDict(currentContainer)
            
            ' 初始化当前货柜号的汇总数量
            Dim totalAlloc As Double, totalInv As Double
            totalAlloc = 0
            totalInv = 0
            Dim matchedInvDate As Date
            
            ' 遍历该货柜号的所有记录，检查日期条件
            Dim k As Long
            For k = LBound(allRecords) To UBound(allRecords)
                Dim singleRecord As Variant
                singleRecord = allRecords(k)
                Dim invDate As Date
                invDate = singleRecord(2)
                
                ' 日期差≤30天则累加数量
                If Abs(currentProcDate - invDate) <= 30 Then
                    totalAlloc = totalAlloc + singleRecord(0)
                    totalInv = totalInv + singleRecord(1)
                    matchedInvDate = invDate ' 可按需保留首个/最后一个匹配日期
                End If
            Next k
            
            ' 有符合条件的记录则写入结果
            If totalAlloc > 0 Or totalInv > 0 Then
                joinWks.Cells(j, 1).Value = currentContainer
                joinWks.Cells(j, 2).Value = totalAlloc
                joinWks.Cells(j, 3).Value = totalInv
                joinWks.Cells(j, 4).Value = matchedInvDate
                joinWks.Cells(j, 5).Value = currentProcDate
                j = j + 1
            End If
        End If
    Next i
    
    Set containerDict = Nothing
End Sub

修正说明 #

1. 字典存储结构优化：每个货柜号对应所有原始记录数组，保留每条记录的数量和发票日期，避免提前合并不同日期的数据。
2. 日期匹配与汇总逻辑：遍历Table1记录时，针对同一货柜号的所有Table2记录逐一检查日期条件，仅累加符合要求的数量。
3. 修复变量错误：将未定义的crDate替换为正确的invDate。
4. 效率优化：初始化写入行号，避免重复查找最后一行，提升代码运行效率。

内容的提问来源于stack exchange，提问作者Clayton Hua