如果列'A‘是相同的，则将多个列加起来

Question

在搜索了一段时间的可用代码之后，我发现这可以检查列A中的值是否相同。如果是这样，则对G列中的任何内容进行汇总，而不是删除所有其他列。

现在，我需要代码能够保持A到E列，并将F到I的值相加。

代码：

Dim WorkRng As Range
Dim Dic As Variant
Dim arr As Variant
On Error Resume Next
xTitleId = "KutoolsforExcel"
Range("A2:I10000").Select
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Set Dic = CreateObject("Scripting.Dictionary")
arr = WorkRng.Value
For i = 1 To UBound(arr, 1)
    Dic(arr(i, 1)) = Dic(arr(i, 1)) + arr(i, 7)
Next
Application.ScreenUpdating = False
WorkRng.ClearContents
WorkRng.Range("A1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys)
WorkRng.Range("G1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.items)
Application.ScreenUpdating = True

有人能告诉我代码做什么以及我需要实现什么才能让它像我所需要的那样工作吗？如果有人只发布我需要的代码，那就太好了，但我想了解并从中吸取教训。

当前简化表：

名称-再次分类访问

项目1.商品1、商品、商业、金融等

项目2.商品1、商品、商业、金融、金融等

项目3.商品2

项目1.商品1、商品、商业、金融等

项目3.商品2

我需要的是：

名称-再次分类访问

项目1.商品1、商品1、金融等

项目2.商品1、商品、商业、金融、金融等

项目3.无偿的商品2

Answer 1

请看下面的评论。这将从输入中生成输出。

Dim WorkRng As Range
Dim Dic As Object
Dim arr As Variant, tmp As Variant
Dim ProjCat As String, xTitleID As String
Dim i As Long
Dim Key

xTitleID = "KutoolsforExcel"
Range("A2:I10000").Select

Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleID, WorkRng.Address, Type:=8)

arr = WorkRng.Value2

Set Dic = CreateObject("Scripting.Dictionary")

For i = LBound(arr, 1) To UBound(arr, 1)
    ' Use a combination key of Name and Category
    ProjCat = arr(i, 1) & "//" & arr(i, 2)
    ' Handle empty values in range
    If Not ProjCat = "//" Then
        If Not Dic.exists(ProjCat) Then
            ' Create empty array for dictionary Item
            ReDim tmp(1 To 2)
            Dic.Add Key:=ProjCat, Item:=tmp
        End If
        ' Set Dictionary item to variable
        tmp = Dic(ProjCat)
        ' Update array with new values
        ' You may need to change these for your columns (assuming they're in columns G and H)
        tmp(1) = tmp(1) + arr(i, 7)
        tmp(2) = tmp(2) + arr(i, 8)
        ' Store array back in dictionary
        Dic(ProjCat) = tmp
    End If
Next i

Application.ScreenUpdating = False
With WorkRng
    .ClearContents
    ' Write back dictionary
    i = 0
    For Each Key In Dic.keys
        i = i + 1
        ' Split the key back into two individual values
        .Range("A" & i).Resize(1, 2) = Split(Key, "//")
        ' Write back results
        .Range("G" & i).Resize(1, 2) = Dic(Key)
    Next Key
End With
Application.ScreenUpdating = True

Answer 2

这并不是一个正确的答案，但是使用了一个枢轴表并稍微调整了布局。

​

​