如果列'A'相同，则汇总多列

Question

在搜索可用代码一段时间后，我发现这是为了检查A列中的值是否相同。如果是这样，它总结了G列中的任何内容。 比它删除所有其他列。

现在我需要Code能够保持列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 Cat1 1 1 项目2 Cat1 1 1 项目3 Cat2 1 1 项目1 Cat1 1 1 项目3 Cat2 1 1

我需要什么：
名称类别访问共享
项目1 Cat1 2 2
项目2 Cat1 1 1 项目3 Cat2 2 2

Answer 1

不是一个正确的答案，但是使用数据透视表并稍微调整布局。

Answer 2

看一下这里的评论。这将生成输入

的输出

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