CODEWITHSUNDEEP
vbaexcel
DRastislav
DRastislav

Reputation: 1882

VBA- Sum values in Column B if name in column A is the same

I try to edit macro for summing values in column B, But it doesnt work correctly:

Here is, what i have:

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

Macro will copy names from column A (removes duplicates) to column D, and values from Column B should sum according to names from A column Part RemoveDuplicates doesnt work properly. Can someone tell me/help me, where can be problem ?

Upvotes: 1

Views: 2568

Answers (3)

gembird
gembird

Reputation: 14053

Another idea could be to use VBA-Collection inside of On-Error-Resume-Next block to filter the duplicite items of the array. So it is not necessary to loop through the temp array. The function will then return this filtered array rather then trying to modify the ByRef parameter. 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

Upvotes: 1

z32a7ul
z32a7ul

Reputation: 3777

I see two errors:

  1. You overwrite tempArray(cur) even if the current element is in the array (the line If B > cur has no effect on the execution of the assignment.

  2. You cannot copy arrays with the assignment operator. And you don't need it either because this algorithm can be done in-place

Furthermore, (a) If (Not StringArray) = True makes no sense, the parameter has to be an array of strings, anyway; (b) Comparing the lenghts and the searching for one string in the other is superfluous, you can just compare them with the = sign (or use StrComp with vbBinaryCompare if you need it to be case-sensitive).

Upvotes: 1

user6432984
user6432984

Reputation: 

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

Upvotes: 2

Related Questions