Adding Rows Together as long as Cell Equals Same Value-CodePudding

I have a problem I am working on for my job. I was given a spreadsheet that lists companies in column B and total units sold per transaction in column A. There are over 3000 lines and about 200 companies.

I need to be able to add all of column A for each set of companies listed in column B.

I can't figure out how to use Range.Find in VBA to do what I need.

CodePudding user response：

Sum Up Unique Using a Dictionary

Here's a more efficient approach. It returns the result in another worksheet.

Option Explicit

Sub CreateUniqueTable()
    
    ' Source range to an array.
    
    Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets("Sheet1")
    
    Dim lRow As Long
    lRow = sws.Cells(sws.Rows.Count, "B").End(xlUp).Row
    
    Dim srg As Range: Set srg = sws.Range("A1:B" & lRow)
    Dim sData As Variant: sData = srg.Value
    
    ' Array to a dictionary (unique and sum).
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim Key As Variant
    Dim r As Long
    
    For r = 2 To UBound(sData)
        dict(sData(r, 2)) = dict(sData(r, 2))   sData(r, 1)
    Next r
    
    Dim rCount As Long: rCount = dict.Count   1
    
    ' Dictionary to another array.
    
    Dim dData As Variant: ReDim dData(1 To rCount, 1 To 2)
    
    ' Write headers.
    dData(1, 1) = sData(1, 2)
    dData(1, 2) = sData(1, 1)
    Erase sData
    
    r = 1
    
    ' Write data.
    For Each Key In dict.Keys
        r = r   1
        dData(r, 1) = Key
        dData(r, 2) = dict(Key)
    Next Key
    
    ' Array to the destination range.
    
    Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets("Sheet2")

    With dws.Range("A1").Resize(, 2)
        .Resize(rCount).Value = dData
        .Resize(dws.Rows.Count - .Row - rCount   1).Offset(rCount).Clear
    End With
    
    ' Inform.
    
    MsgBox "Unique table created.", vbInformation
    
End Sub

CodePudding user response：

I know you asked for a VBA solution but I thought I'd offer a formula approach just in case you find it useful.

First, create a list of unique company names. Reference this