向 Dictionary .VBA 添加多个值

Question

我是 VBA 的绝对新手。我想在字典中添加多个值，以按项目的数量对具有相同值的表进行分组。 所以我有这张桌子

1   10  A5  Text1   Audi1   Auto1   100
2   10  A5  Text1   Audi1   Auto1   100
3   10  A5  Text1   Audi1   Auto1   100
4   10  A4  Text4   Audi4   Auto4   200
5   10  A6  Text5   Audi5   Auto5   300
6   10  A6  Text5   Text5   Text5   300
7   10  A5  Text1   Audi1   Auto1   100
8   10  A4  Text4   Audi4   Auto4   200
9   10  A2  Text9   Audi9   Auto9   50
10  10  A1  Text10  Audi10  Auto10  25

现在我想将它们组合在一起，它应该如下所示：

1   40  A5  Text1   Audi1   Auto1   100    
2   20  A4  Text4   Audi4   Auto4   200    
3   20  A6  Text5   Audi5   Auto5   300    
4   10  A2  Text9   Audi9   Auto9   50    
5   10  A1  Text10  Audi10  Auto10  25

我的实际 VBA 是这样的：

Sub Schaltfläche1_Klicken()

Dim WkSh    As Worksheet
Dim aTemp   As Variant
Dim lZeile  As Long
Dim rZelle  As Range
Dim Dict    As Variant

   Set WkSh = ThisWorkbook.Worksheets("Tabelle1")

   With WkSh ' die Fahrzeuge aus A2:Bn in einen temporären Array schreiben
      aTemp = .Range("B13:G" & .Cells(.Rows.Count, 1).End(xlUp).Row)
   End With

   WkSh.Range("B13:G1000").ClearContents ' den Bereich D2:E100 leeren/löschen

   Set Dict = CreateObject("Scripting.Dictionary")

   On Error Resume Next

'     die Daten an das Dictionary übergeben
   For lZeile = 1 To UBound(aTemp)
      Dict(aTemp(lZeile, 2)) = Dict(aTemp(lZeile, 2)) + aTemp(lZeile, 1)
      Next lZeile
'
'    ausgeben
'
   Set rZelle = WkSh.Cells(13, 2) ' Bereich festlegen wo hingeschrieben werden soll Beispiel: cells(5,1) -> Reihe 5 Spalte 1
'
   Application.EnableEvents = False
   rZelle.Resize(Dict.Count) = WorksheetFunction.Transpose(Dict.Items)
   rZelle.Offset(0, 1).Resize(Dict.Count) = WorksheetFunction.Transpose(Dict.Keys)
   Application.EnableEvents = True

End Sub

然后给我这个输出：

1   40  A5
2   20  A4
3   20  A6
4   10  A2
5   10  A1

有人可以帮助我，以实现我想要的输出。

Answer 1

使用字典。字典键是从 B:F 列的串联创建的。如果键已存在，则将 A 列值添加到该键的现有值中。

Option Explicit
Public Sub GetTotals()
    Dim inputRange As Range, dict As Object, arr(), i As Long, uniqueKey As String, ws As Worksheet

    Application.ScreenUpdating = False

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set inputRange = ws.Range("A1:F10")
    Set dict = CreateObject("Scripting.Dictionary")
    arr = inputRange.Value

    For i = LBound(arr, 1) To UBound(arr, 1)
        uniqueKey = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5) & "," & arr(i, 6)
        dict(uniqueKey) = dict(uniqueKey) + arr(i, 1)
    Next i
    Dim key As Variant, tempArr() As String, rowCounter As Long
    rowCounter = inputRange.Offset(inputRange.Rows.Count + 2, 0).Row

    With ws
        For Each key In dict.keys
            .Cells(rowCounter, 1) = dict(key)
            tempArr = Split(key, ",")
            .Cells(rowCounter, 2).Resize(1, UBound(tempArr) + 1) = tempArr
            rowCounter = rowCounter + 1
        Next key
    End With

      Application.ScreenUpdating = True
End Sub

---

仅输出 2 列并忽略额外不需要的行的版本：

Option Explicit
Public Sub GetTotals()
    Dim inputRange As Range, dict As Object, arr(), i As Long, uniqueKey As String, ws As Worksheet

    Application.ScreenUpdating = False

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set inputRange = ws.Range("A1:F10")
    Set dict = CreateObject("Scripting.Dictionary")
    arr = inputRange.Value

    For i = LBound(arr, 1) To UBound(arr, 1)
        If Not (arr(i, 4)) = "Text5" Then
            uniqueKey = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5) & "," & arr(i, 6)
            dict(uniqueKey) = dict(uniqueKey) + arr(i, 1)
        End If
    Next i
    Dim key As Variant, tempArr() As String, rowCounter As Long
    rowCounter = inputRange.Offset(inputRange.Rows.Count + 2, 0).Row

    With ws
        For Each key In dict.keys
            .Cells(rowCounter, 1) = dict(key)
            tempArr = Split(key, ",")

            .Cells(rowCounter, 2) = tempArr(0)
            rowCounter = rowCounter + 1
        Next key
    End With

    Application.ScreenUpdating = True
End Sub

---

版本 1：数据在顶部。数据在底部。

版本 2：2 列；忽略错误。

Answer 2

另一个基于 Scripting.Dictionary 的解决方案。

Sub Schaltfläche1_Klicken()
    Dim i As Long, j As Long, tmp As String
    Dim aTemp  As Variant, dict As Object

    With ThisWorkbook.Worksheets("Tabelle1")
        aTemp = .Range(.Cells(13, "B"), .Cells(.Rows.Count, "G").End(xlUp)).Value2
        .Range(.Cells(13, "B"), .Cells(.Rows.Count, "G").End(xlUp)).ClearContents

        Set dict = CreateObject("scripting.dictionary")
        dict.comparemode = vbBinaryCompare

        For i = LBound(aTemp, 1) To UBound(aTemp, 1)
            tmp = Join(Array(aTemp(i, 2), aTemp(i, 3), aTemp(i, 4), aTemp(i, 5), aTemp(i, 6)), ChrW(8203))
            dict.Item(tmp) = dict.Item(tmp) + aTemp(i, 1)
        Next i

        With .Cells(13, "B").Resize(dict.Count, 1)
            .Offset(0, -1).Resize(1, 1) = 1
            .Offset(0, -1).Resize(dict.Count, 1).DataSeries Rowcol:=xlColumns, _
                    Type:=xlLinear, Step:=1, Stop:=dict.Count
            .Value = Application.Transpose(dict.items)
            .Offset(0, 1).Value = Application.Transpose(dict.keys)
            .Offset(0, 1).TextToColumns Destination:=.Offset(0, 1), DataType:=xlDelimited, ConsecutiveDelimiter:=False, _
                                        Other:=True, Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
                                        OtherChar:=ChrW(8203), FieldInfo:=Array(Array(1, 1), Array(2, 1))
        End With

    End With

End Sub