Excel Scripting Dictionary VBA – 区分重复项

问题描述

我有两个表格，我想根据集装箱号码将它们连接起来。我的问题是，集装箱在3个月后可能会重复，这会将所有数量汇总在一起。表1中，我有集装箱号码以及它们的处理日期。表2中有集装箱号码、数量和发票日期。我认为，通过查看处理日期和发票日期之间的差值，并限制最大30天，可以将集装箱号码和正确数量的匹配，因为一个集装箱不能在至少3个月内重复。

请参考下面的代码，我使用脚本字典将表2中的集装箱、数量和发票日期写入。然后，表1循环处理日期。我的初步问题是，当循环进行时，它只捕获一行，而不是我需要的多行数量的总和。有什么建议吗？如果有更好的方法，我愿意学习。谢谢！

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

需要求和的Table2的图片：

解决方案

无法更新包含在字典中的数组-必须先将数组提取到变量中，然后更新它，最后用编辑后的版本替换存储在字典中的数组。

例如：

Dim tmp
'...
'...

If containerDict.exists(Container) Then
    tmp = containerDict(Container)  'copy to local variable
    tmp(0) = tmp(0) + allocQty      'update local copy
    tmp(1) = tmp(1) + invQty
    containerDict(Container) = tmp  'copy to dict
Else
    containerDict(Container) = Array(allocQty, invQty, invDate)
End If

你的数组只能捕获每个容器的第一个日期，所以这种方法最终会将所有日期相加…

对于从SharePoint或其他HTTP位置打开的文件，首先保存为本地临时副本进行了一些更改

例如:

Public Sub JoinandSum()

    Dim oCon As Object, rs As Object, conn As String
    Dim wb As Workbook, tblA As ListObject, tblB As ListObject, sql As String

    Set wb = ThisWorkbook
    Set tblA = wb.Worksheets("Input").ListObjects("Table1")
    Set tblB = wb.Worksheets("Input").ListObjects("Table2")

    conn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & QueryPath(ThisWorkbook) & ";" & _
                        "Extended Properties=""Excel 12.0;"";"

    sql = " select a.Container, a.[Process Date], sum(b.[Invoice Qty]) as TotQty, " & _
          " min(b.[Invoice Date]) as MinInvDate, max(b.[Invoice Date]) as MaxInvDate " & _
          " from " & TableRef(tblA) & " a, " & TableRef(tblB) & " b " & _
          " where a.Container = b.Container and " & _
          " abs(a.[Process Date] - b.[Invoice Date])<30 " & _
          " group by a.Container, a.[Process Date]"

    Set oCon = CreateObject("ADODB.Connection")
    oCon.Open conn
    Set rs = oCon.Execute(sql)
    PutResults rs, wb.Worksheets("Input").Range("J1")

    rs.Close
    oCon.Close

End Sub

'When using ADO to query a workbook, figure out if it's opened from
'   an HTTP path, and if it is then make a temporary local copy as the data source
'Note: does not currently handle unsaved workbooks... 
Function QueryPath(wb As Workbook) As String
    Dim p As String
    p = wb.FullName
    If UCase(p) Like "HTTP*" Then
        p = Environ("temp") & "\" & wb.Name
        ThisWorkbook.SaveCopyAs p
    End If
    Debug.Print "Using file" & vbLf & p
    QueryPath = p
End Function

'return a string referencing a listobject, for use in sql
Function TableRef(lo As ListObject)
    TableRef = "[" & lo.Parent.Name & "$" & lo.Range.Address(False, False) & "]"
End Function

'Populate a range with the content of a recordset, including the field names
Sub PutResults(rs As Object, rng As Range)
    Dim f, i As Long
    For Each f In rs.Fields
        rng(1).Offset(0, i).Value = f.Name
        i = i + 1
    Next f
    If Not rs.EOF Then rng(1).Offset(1).CopyFromRecordset rs
End Sub

示例输入/输出: