Excel Macro: How to copy all rows from 3 worksheets and merge rows that are unique in the first column

excelexcel-2003vba

The worksheets have hundreds of rows with account numbers in column A, an account description in column B and totals in column C. I want to copy the rows from all 3 worksheets into a single 4th worksheet but where duplicate account numbers are found, I want there just to be one with the totals aggregated into column C of that row and the extras deleted, like this:

Input from sheets (all the sheets are in one .xls file):

Sheet 1 of workbook

                A                     B                       C
1            abc-123            Project Costs             1,548.33
2            abc-321           Housing Expenses                250
3            abc-567           Helicopter Rides          11,386.91

Sheet 2 of workbook

                A                     B                       C
1            abc-123            Project Costs             1,260.95
2            abc-321           Housing Expenses                125
3            abc-567           Helicopter Rides          59,605.48

Sheet 3 of workbook

                A                     B                       C
1            abc-123            Project Costs             1,785.48
2            abc-321           Housing Expenses                354
3            def-345            Elephant Treats         814,575.31

What I would want the result to be:

                A                     B                       C
1            abc-123            Project Costs             4,642.28
2            abc-321           Housing Expenses                729
3            abc-567           Helicopter Rides          70,992.39
4            def-345            Elephant Treats         814,575.31

Notice: Some of the account numbers don't ever repeat, but some do.

Best Answer

Here's one way.

Option Explicit

Sub Test()
    Dim sheetNames: sheetNames = Array("Sheet1", "Sheet2", "Sheet3")
    Dim target As Worksheet: Set target = Worksheets("Sheet4")
    Dim accounts As New Dictionary
    Dim balances As New Dictionary
    Dim source As Range
    Dim row As Range
    Dim id As String
    Dim account As String
    Dim balance As Double
    Dim sheetName: For Each sheetName In sheetNames
        Set source = Worksheets(sheetName).Range("A1").CurrentRegion
        Set source = source.Offset(1, 0).Resize(source.Rows.Count - 1, source.Columns.Count)
        For Each row In source.Rows
            id = row.Cells(1).Value
            account = row.Cells(2).Value
            balance = row.Cells(3).Value
            accounts(id) = account
            If balances.Exists(id) Then
                balances(id) = balances(id) + balance
            Else
                balances(id) = balance
            End If
        Next row
    Next sheetName

    Call target.Range("A2:A65536").EntireRow.Delete

    Dim rowIndex As Long: rowIndex = 1
    Dim key
    For Each key In accounts.Keys
        rowIndex = rowIndex + 1
        target.Cells(rowIndex, 1).Value = key
        target.Cells(rowIndex, 2).Value = accounts(key)
        target.Cells(rowIndex, 3).Value = balances(key)
    Next key
End Sub

  1. Create a new module (VBA editor -> Insert -> Module) and paste the above code into it.

  2. Add a reference to Microsoft Scripting Runtime (VBA editor -> Tools -> References -> Check 'Microsoft Scripting Runtime').

  3. Run it by placing the cursor within the code and pressing F5.

Obviously the sheets will have to be named Sheet1, Sheet2, Sheet3 and Sheet4. It won't paste the column headers into Sheet4 but presumably they are static so you can just set them up yourself beforehand.

Related Topic