VBA-如果A列中的名称相同，则B列中的总和值

我尝试编辑宏以对B列中的值求和，但它无法正常工作：

以下是我所拥有的：

Option Explicit

Sub Main()

    CollectArray "A", "D"

    DoSum "D", "E", "A", "B"

End Sub


' collect array from a specific column and print it to a new one without duplicates
' params:
'           fromColumn - this is the column you need to remove duplicates from
'           toColumn - this will reprint the array without the duplicates
Sub CollectArray(fromColumn As String, toColumn As String)

    ReDim arr(0) As String

    Dim i As Long
    For i = 1 To Range(fromColumn & Rows.Count).End(xlUp).Row
        arr(UBound(arr)) = Range(fromColumn & i)
        ReDim Preserve arr(UBound(arr) + 1)
    Next i
    ReDim Preserve arr(UBound(arr) - 1)
    RemoveDuplicate arr
    Range(toColumn & "1:" & toColumn & Range(toColumn & Rows.Count).End(xlUp).Row).ClearContents
    For i = LBound(arr) To UBound(arr)
        Range(toColumn & i + 1) = arr(i)
    Next i
End Sub


' sums up values from one column against the other column
' params:
'           fromColumn - this is the column with string to match against
'           toColumn - this is where the SUM will be printed to
'           originalColumn - this is the original column including duplicate
'           valueColumn - this is the column with the values to sum
Private Sub DoSum(fromColumn As String, toColumn As String, originalColumn As String, valueColumn As String)
    Range(toColumn & "1:" & toColumn & Range(toColumn & Rows.Count).End(xlUp).Row).ClearContents
    Dim i As Long
    For i = 1 To Range(fromColumn & Rows.Count).End(xlUp).Row
        Range(toColumn & i) = WorksheetFunction.SumIf(Range(originalColumn & ":" & originalColumn), Range(fromColumn & i), Range(valueColumn & ":" & valueColumn))
    Next i
End Sub


Private Sub RemoveDuplicate(ByRef StringArray() As String)
    Dim lowBound$, UpBound&, A&, B&, cur&, tempArray() As String
    If (Not StringArray) = True Then Exit Sub
    lowBound = LBound(StringArray): UpBound = UBound(StringArray)
    ReDim tempArray(lowBound To UpBound)
    cur = lowBound: tempArray(cur) = StringArray(lowBound)
    For A = lowBound + 1 To UpBound
        For B = lowBound To cur
            If LenB(tempArray(B)) = LenB(StringArray(A)) Then
                If InStrB(1, StringArray(A), tempArray(B), vbBinaryCompare) = 1 Then Exit For
            End If
        Next B
        If B > cur Then cur = B
        tempArray(cur) = StringArray(A)
    Next A
    ReDim Preserve tempArray(lowBound To cur): StringArray = tempArray
End Sub

宏将把A列中的名称（删除重复项）复制到D列，B列中的值应根据A列中的名称求和 拆下的零件副本无法正常工作。有人能告诉我/帮助我吗，哪里有问题

我看到两个错误：

Sub CreateSummary()
    Dim x As Long
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    For x = 1 To Range("A" & Rows.Count).End(xlUp).Row
        dict(Cells(x, 1).Value) = dict(Cells(x, 1).Value) + Cells(x, 2).Value
    Next

    Range("D1").Resize(dict.Count).Value = Application.Transpose(dict.Keys)
    Range("E1").Resize(dict.Count).Value = Application.Transpose(dict.Items)

End Sub

即使当前元素在数组中（如果B>cur对赋值的执行没有影响的行），也可以覆盖tempArray（cur）

您不能使用赋值运算符复制数组。而且您也不需要它，因为此算法可以就地完成

此外，（a）如果（Not StringArray）=True没有意义，那么该参数无论如何都必须是字符串数组；（b）比较长度和在另一个字符串中搜索一个字符串是多余的，您可以将它们与=符号进行比较（或者如果需要区分大小写，可以使用StrComp和vbBinaryCompare）。

我看到两个错误：

即使当前元素在数组中（如果B>cur对赋值的执行没有影响的行），也可以覆盖tempArray（cur）

您不能使用赋值运算符复制数组。而且您也不需要它，因为此算法可以就地完成

---

此外，（a）如果（Not StringArray）=True没有意义，那么无论如何，参数必须是字符串数组；（b）比较长度和在另一个字符串中搜索一个字符串是多余的，您可以将它们与=符号进行比较（或者如果需要区分大小写，请使用StrComp和vbBinaryCompare）

Sub test()
    Dim arr(0 To 4) As String
    arr(0) = "AAA"
    arr(1) = "BBB"
    arr(2) = "AAA"
    arr(3) = "CCC"
    arr(4) = "AAA"

    Dim arrFiltered() As String
    arrFiltered = RemoveDuplicate(arr)

End Sub

Private Function RemoveDuplicate(ByRef StringArray() As String) As String()
    Dim tempArray As Collection
    Dim resultArray() As String
    Dim item As Variant
    Dim i As Integer

    Set tempArray = New Collection

    On Error Resume Next
    For Each item In StringArray
        tempArray.Add item, item
    Next item
    On Error GoTo 0

    ReDim resultArray(0 To tempArray.Count - 1)
    For Each item In tempArray
        resultArray(i) = item
        i = i + 1
    Next item

    RemoveDuplicate = resultArray
End Function

---

另一种方法是在错误恢复下一步块中使用

VBA集合

来过滤数组中的重复项。因此，不必在临时数组中循环。该函数将返回此过滤后的数组，而不是尝试修改

ByRef

参数。HTH

Sub test()
    Dim arr(0 To 4) As String
    arr(0) = "AAA"
    arr(1) = "BBB"
    arr(2) = "AAA"
    arr(3) = "CCC"
    arr(4) = "AAA"

    Dim arrFiltered() As String
    arrFiltered = RemoveDuplicate(arr)

End Sub

Private Function RemoveDuplicate(ByRef StringArray() As String) As String()
    Dim tempArray As Collection
    Dim resultArray() As String
    Dim item As Variant
    Dim i As Integer

    Set tempArray = New Collection

    On Error Resume Next
    For Each item In StringArray
        tempArray.Add item, item
    Next item
    On Error GoTo 0

    ReDim resultArray(0 To tempArray.Count - 1)
    For Each item In tempArray
        resultArray(i) = item
        i = i + 1
    Next item

    RemoveDuplicate = resultArray
End Function

---

@DRastislav，这是宏速度和长度方面最好的解决方案：为什么你不选择这个？@user3598756谢谢。OP可能对更正自己的代码更感兴趣，z32a7ul为他做了这件事。更不用说我完全缺乏文档。哇，对不起，托马斯，我对我的代码更感兴趣，但正如我所见，你r答案更好+代码更少：）-接受你的建议answer@DRastislav，这是针对宏速度和长度的最佳解决方案：你为什么不选择这个？@user3598756谢谢。OP可能对更正自己的代码更感兴趣，z32a7ul为他做了这件事。更不用说我完全缺乏文档。哇，对不起，托马斯，我对自己的代码更感兴趣，但正如我所看到的，你的答案更好+更少的代码：）-接受你的答案