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

我的actaul 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

给我这个输出：

有人可以帮我实现我想要的输出吗？

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

另一种基于脚本的词典解决方案。

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

将多个值添加到Dictionary .VBA

2 个答案: