如何用VBA去除数组重复项并汇总对应Qty Reqd列数值？

原始透视表数据（含空行） #

需求目标 #

以Item Num为唯一键去除重复项，同时汇总对应Qty Reqd的数值，最终生成的Word表格需如下：

当前困境 #

已实现将3列数据存入数组并写入Word，但无法完成去重+求和的逻辑。尝试用Scripting.Dictionary去重时，没法关联Material、Item Num和Qty Reqd三者的关系，也做不到自动求和。

现有代码片段 #

数据提取代码 #

Material = Item.Offset(0, 4).Text
If Material <> "(blank)" Then
  MaterialList(UBound(MaterialList)) = Material
  ItemList(UBound(ItemList)) = Item.Offset(0, 5).Text
  QtyList(UBound(QtyList)) = Item.Offset(0, 6).Text
  ReDim Preserve MaterialList(UBound(MaterialList) + 1)
  ReDim Preserve ItemList(UBound(ItemList) + 1)                                                                        
  ReDim Preserve QtyList(UBound(QtyList) + 1)
End If

Word写入代码 #

' If Material exists, go to the Word BM and place the quick part Material Table in the doc
If UBound(MaterialList) > 0 Then 
  objDoc.Bookmarks("Material_Table").Select
  objWord.Templates(TemplateName). _
  BuildingBlockEntries("Material_Table").Insert _
  Where:=objWord.Selection.Range, _
  RichText:=True
  objDoc.Bookmarks("Material").Select

' Count how many table rows to add                                              
If UBound(MaterialList) > 1 Then objWord.Selection.InsertRowsBelow (UBound(MaterialList) - 1)
objDoc.Bookmarks("Material").Select

' Then place the data in the table cells
For Each Item In MaterialList 
  If Item <> "" Then
     objWord.Selection.TypeText Text:=Item
     objWord.Selection.MoveDown
  End If
Next Item
                                              
objDoc.Bookmarks("Stk").Select
For Each Item In ItemList
   objWord.Selection.TypeText Text:=Item
   objWord.Selection.MoveDown
Next Item

objDoc.Bookmarks("Qty").Select
For Each Item In QtyList
   objWord.Selection.TypeText Text:=Item
   objWord.Selection.MoveDown
Next Item

Else ' get rid of the BM
   objDoc.Bookmarks("Material_Table").Select
   objWord.Selection.Delete
End If

去重尝试代码 #

Set oDict = CreateObject("Scripting.Dictionary")
For i = LBound(MaterialList) To UBound(MaterialList)
   oDict(MaterialList(i)) = True
Next
MaterialList = oDict.Keys()

解决方案 #

核心思路是用Item Num作为Dictionary的唯一键，每个键对应存储Material和累计的Qty Reqd（用数组存储这两个值即可）。具体步骤如下：

1. 遍历提取好的三个数组，以ItemList中的值为键
2. 若键不存在，就把当前的Material和Qty Reqd数值存入Dictionary的Item中
3. 若键已存在，就取出原有的Qty数值，和当前Qty相加后更新回去
4. 最后从Dictionary中导出处理后的三个数组，再用原有的Word写入代码即可

修改后的处理代码如下：

' 声明Dictionary和临时变量
Set oDict = CreateObject("Scripting.Dictionary")
Dim currentItem As String
Dim currentMaterial As String
Dim currentQty As Double
Dim storedData As Variant

' 遍历原始数组（排除最后一个空元素，因提取时ReDim多了一个位置）
For i = LBound(MaterialList) To UBound(MaterialList) - 1
    currentItem = ItemList(i)
    currentMaterial = MaterialList(i)
    ' 将Qty转为数值类型，方便求和
    currentQty = CDbl(QtyList(i))
    
    If oDict.Exists(currentItem) Then
        ' 键已存在，累加Qty
        storedData = oDict(currentItem)
        storedData(1) = storedData(1) + currentQty
        oDict(currentItem) = storedData
    Else
        ' 键不存在，添加新条目：数组第1位存Material，第2位存Qty
        oDict.Add currentItem, Array(currentMaterial, currentQty)
    End If
Next i

' 清空原有数组，重新填充处理后的数据
ReDim MaterialList(0 To oDict.Count - 1)
ReDim ItemList(0 To oDict.Count - 1)
ReDim QtyList(0 To oDict.Count - 1)

Dim key As Variant
Dim idx As Integer
idx = 0
For Each key In oDict.Keys
    ItemList(idx) = key
    storedData = oDict(key)
    MaterialList(idx) = storedData(0)
    QtyList(idx) = storedData(1)
    idx = idx + 1
Next key

把这段代码放在数据提取完成后，Word写入代码之前，替换原来的去重尝试代码即可。处理后的三个数组就是去重并求和后的结果，直接用原有的Word写入逻辑就能生成目标表格。

注意事项：

• 确保QtyList中的值能正常转为数值类型，若原始数据有非数字内容，需添加错误处理
• 提取数据时最后会多一个空元素，所以遍历到UBound(MaterialList)-1即可

内容的提问来源于stack exchange，提问作者Brad Coulding