Question

我尝试编辑宏来对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列中的名称求和部分RemoveDuplicates无法正常工作。有人可以告诉我/帮助我，哪里可以有问题？

Answer 1

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

Answer 2

我看到两个错误：

即使当前元素在数组中，也会覆盖tempArray（cur）（如果B＆gt; cur对执行赋值没有影响。
您无法使用赋值运算符复制数组。你也不需要它，因为这个算法可以就地完成

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

Answer 3

另一个想法可能是使用VBA-Collection块内的On-Error-Resume-Next来过滤数组的重复项。因此没有必要遍历临时数组。然后，该函数将返回此已过滤的数组，而不是尝试修改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

如果A列中的名称相同，则BBA中的VBA- Sum值

3 个答案: