删除重复项并对数组中的列求和?

Removing duplicates and summing columns in arrays?

提问人:Brad Coulding 提问时间:11/14/2023 最后编辑:Brad Coulding 更新时间:11/14/2023 访问量:78

问:

我有一个包含许多列的 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()

所有的帮助都非常感谢。

Excel VBA MS-Word

评论

1赞 Ike 11/14/2023
为什么不在 Excel 中根据数据透视表的源数据创建输出,该数据对唯一值求和。无需在 VBA 中执行此操作。然后将此表放入 Word 文档中
0赞 Brad Coulding 11/14/2023
嗨,艾克,我在透视表中有很多信息,这些信息在其他表中使用。透视透视被过滤,因此不会使用源数据中的所有信息。同样重要的是,有关材料的信息仍与此其他信息相关,因此创建自定义透视或直接访问源数据不是一种选择。
0赞 Ike 11/15/2023
数据透视表不受影响...相反,您将有两个输出:1) 原始数据 --> pivot;2)原始数据-->汇总表-->输出到Word。您可以动态创建第二个输出,并在将其添加到 Word 后将其删除。

答:

0赞 JSmart523 11/14/2023 #1

您从错误的数据透视表复制数据。😉

在没有这些额外列的新选项卡/工作表中创建一个新的数据透视表,您将为您删除重复数据并聚合结果。

如果您可以控制工作簿设计,只需将其添加到新工作表中(并考虑隐藏工作表)。

如果你不这样做,那么你将不得不在内存中构建数据透视表(即你创建和丢弃而不保存的工作簿)。要对此进行编码,请通过记录创建新工作簿的宏来“作弊”,根据您最初使用的数据或数据透视表创建该数据透视表,并在完成后关闭工作簿而不保存。这个宏不会完全是你想要的代码,但它会给你一个巨大的领先优势。

评论

0赞 Brad Coulding 11/14/2023
但是,谢谢,重要的是,有关材料的信息与枢轴中的其他信息保持相关,因此不幸的是,创建另一个枢轴将破坏该连接。
0赞 JSmart523 11/14/2023
等。。。你是在告诉我你不能有两个单独的数据透视表,因为它们会相互干扰吗?如果是这样,我从未听说过,很想知道更多。
1赞 FaneDuru 11/14/2023 #2

请尝试下一个代码。它使用字典来获取唯一键及其总和。然后将字典数据放在最后一个数组 () 中,然后打开一个新的 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

评论

0赞 Soma 11/16/2023
拜托,我不明白这部分dict(arr(i, 1) & "|" & arr(i, 2)) = _ dict(arr(i, 1) & "|" & arr(i, 2)) + arr(i, 3)
0赞 FaneDuru 11/16/2023
@Soma 什么意思? 它是前两个数组列之间的简单连接,用“|”分隔。 为相应的列组合创建 UNIQUE 键。并且整个代码行汇总了第三列的值,用于前两列的唯一组合。arr(i, 1) & "|" & arr(i, 2)dict(arr(i, 1) & "|" & arr(i, 2))