我有一个包含许多列的 Excel 数据透视表，我想对其中 3 列进行汇总，然后通过 VBA 将其放入 Word 文档的表格中。
数据透视表中的数据结构与下表类似，左侧还有许多其他列。
| 材质 | 商品编号 | 需求数量 |
|---|---|---|
| 油 | 123 | 1 |
| 螺栓 | 987 | 4 |
| （空白） | （空白） | （空白） |
| 油 | 123 | 9 |
| （空白） | （空白） | （空白） |
| 螺栓 | 321 | 8 |
| 油 | 123 | 4 |
| （空白） | （空白） | （空白） |
我想使用“项目编号”作为关键字段来消除重复项，因为它始终是唯一的。然后，我想对所需数量求和，以便 Word 中的表格如下所示。
| 材质 | 商品编号 | 需求数量 |
|---|---|---|
| 油 | 123 | 14 |
| 螺栓 | 987 | 4 |
| 螺栓 | 321 | 8 |
我在这方面并没有取得多大成功。我只是在word文档写完之后手动做的。
我当前用来获取 3 列并将它们放入数组的代码如下。
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()
非常感谢所有帮助。
您正在从错误的数据透视表复制数据。 😉
在没有这些额外列的新选项卡/工作表中创建一个新的数据透视表，您将获得重复数据删除和聚合的结果。
如果您可以控制工作簿设计，只需将其添加到新工作表中（并考虑隐藏该工作表）。
如果不这样做，那么您将必须在内存中构建数据透视表（即您创建并丢弃而不保存的工作簿）。要对此进行编码，请通过记录创建新工作簿的宏，根据数据或您最初使用的数据透视表创建数据透视表，并在完成后关闭工作簿而不保存来“作弊”。这个宏并不完全是您想要的代码，但它会给您一个巨大的领先优势。
请尝试下一个代码。它使用字典来获取唯一键及其总和。然后将字典数据放入最终数组中（
arrFinSub ExtractUniquePlaceInWordTable()
Dim ws As Worksheet, lastR As Long, arr, arrFin
Dim i As Long, k As Long, dict As New Scripting.Dictionary
Set ws = ActiveSheet
lastR = ws.Range("A" & ws.rows.count).End(xlUp).Row
arr = ws.Range("A1:C" & lastR).Value2
'load the dictionary with unique summarized data:
For i = 2 To UBound(arr)
If arr(i, 1) <> "" And arr(i, 1) <> "(blank)" Then
dict(arr(i, 1) & "|" & arr(i, 2)) = _
dict(arr(i, 1) & "|" & arr(i, 2)) + arr(i, 3)
End If
Next i
'Populate final arr:
ReDim arrFin(1 To dict.count + 1, 1 To 3)
'load the header:
For i = 1 To 3: arrFin(1, i) = arr(1, i): Next i
k = 1
For i = 0 To dict.count - 1
k = k + 1
arrFin(k, 1) = Split(dict.keys()(i), "|")(0)
arrFin(k, 2) = Split(dict.keys()(i), "|")(1)
arrFin(k, 3) = dict.Items()(i)
Next i
'open a new Word session, open a new document, insert a table and populate it with the array content
Dim objWord, doc As Object, tbl As Object
Set objWord = CreateObject("Word.Application")
With objWord
.Visible = True
Set doc = .Documents.Add
With doc
Set tbl = .tables.Add(Range:=.Range(0, 0), NumRows:=UBound(arrFin), NumColumns:=UBound(arrFin, 2))
With tbl
.Borders.InsideLineStyle = 1 '[wdLineStyleSingle
.Borders.OutsideLineStyle = 7 'wdLineStyleDouble
.rows.SetLeftIndent LeftIndent:=-37, RulerStyle:=0 'wdAdjustNone
'fill the table from the array:
For i = 1 To UBound(arrFin)
For k = 1 To UBound(arrFin, 2)
.cell(i, k).Range.text = arrFin(i, k)
Next k
Next i
End With
End With
End With
MsgBox "Ready..."
End Sub