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

问题描述 投票:0回答:2

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

非常感谢所有帮助。

excel vba ms-word
2个回答
0
投票

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

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

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

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


0
投票

请尝试下一个代码。它使用字典来获取唯一键及其总和。然后将字典数据放入最终数组中(

arrFin
),然后打开一个新的Word会话,打开一个新文档,插入一个表格并用上面的数组内容填充它:

Sub 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
© www.soinside.com 2019 - 2024. All rights reserved.