提问人:Brad Coulding 提问时间:11/14/2023 最后编辑:Brad Coulding 更新时间:11/14/2023 访问量:78
删除重复项并对数组中的列求和?
Removing duplicates and summing columns in arrays?
问:
我有一个包含许多列的 Excel 数据透视表,我想总结其中的 3 列,然后通过 VBA 放置在 word 文档上的表格中。
数据透视表中的数据结构与下表中的数据类似,左侧还有许多其他列。
材料 | 项目编号 | 数量 Reqd |
---|---|---|
油 | 123 | 1 |
螺栓 | 987 | 4 |
(空白) | (空白) | (空白) |
油 | 123 | 9 |
(空白) | (空白) | (空白) |
螺栓 | 321 | 8 |
油 | 123 | 4 |
(空白) | (空白) | (空白) |
我想使用“项目编号”作为键字段来消除重复项,因为它将始终是唯一的。然后,我想对 Qty Reqd 求和,因此 word 中的表格如下所示。
材料 | 项目编号 | 数量 Reqd |
---|---|---|
油 | 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()
所有的帮助都非常感谢。
答:
您从错误的数据透视表复制数据。😉
在没有这些额外列的新选项卡/工作表中创建一个新的数据透视表,您将为您删除重复数据并聚合结果。
如果您可以控制工作簿设计,只需将其添加到新工作表中(并考虑隐藏工作表)。
如果你不这样做,那么你将不得不在内存中构建数据透视表(即你创建和丢弃而不保存的工作簿)。要对此进行编码,请通过记录创建新工作簿的宏来“作弊”,根据您最初使用的数据或数据透视表创建该数据透视表,并在完成后关闭工作簿而不保存。这个宏不会完全是你想要的代码,但它会给你一个巨大的领先优势。
评论
请尝试下一个代码。它使用字典来获取唯一键及其总和。然后将字典数据放在最后一个数组 () 中,然后打开一个新的 Word 会话,打开一个新文档,插入一个表格并用上面的数组内容填充它:arrFin
Sub ExtractUniquePlaceInWordTable()
Dim ws As Worksheet, lastR As Long, arr, arrFin
Dim i As Long, k As Long, dict As Object
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:
Set dict = CreateObject("Scripting.Dictionary")
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
评论
dict(arr(i, 1) & "|" & arr(i, 2)) = _ dict(arr(i, 1) & "|" & arr(i, 2)) + arr(i, 3)
arr(i, 1) & "|" & arr(i, 2)
dict(arr(i, 1) & "|" & arr(i, 2))
下一个:在 Word 文档中存储多个位置
评论