Combine Rows & Sum Values in a Worksheet

Question

I have an excel sheet with the below (pipe "|" to delimit columns) data.

A|B|C|X|50|60
D|E|F|X|40|30
A|B|C|X|10|20
A|B|C|Y|20|20
A|B|C|X|20|70
D|E|F|X|10|50
A|B|C|Y|10|10

The result I am trying to get is:

A|B|C|X|80|150
A|B|C|Y|30|30
D|E|F|X|50|80

Values A, B, C and D, E, F are like unique identifiers. Actually only A or D can be considered. Values X and Y are like "types", and the integers are the values to sum. This sample was simplified, there are thousands of unique identifiers, dozen of types and dozens of values to sum. The rows are not sorted, the types can be located in higher or lower rows. I am trying to avoid the use of a pivot table.

Dim LastRow As Integer
Dim LastCol As Integer
Dim i As Integer

LastCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To LastRow
????
Next i

The code above gets to the point of looping through the rows but I am unclear on what to after that point.

Answer 1

1. Sort them on all alphabetic columns you deem important.

2. In an unused column to the right use a formula like the following in the second row,

   =IF($A2&$B2&$C2&$D2=$A3&$B3&$C3&$D3, "", SUMIFS(E:E,$A:$A, $A2,$B:$B, $B2,$C:$C, $C2,$D:$D, $D2))

3. Copy that formula right one column then fill both columns down as far as your data goes

4. Filter on the two columns, removing blanks.

           

5. Optionally copy the data to a new report worksheet and remove columns E & F.

Addendum:

A more automated approach could be achieved with some form of array and some simple mathematical operations. I've chosen a dictionary object in order to take use of its indexed Key to recognize patterns in the first four alphabetic identifiers.

To use a scripting dictionary, you need to go into the VBE's Tools ► References and add Microsoft Scripting Runtime. The following code will not compile without it.

The following has been adjusted for dynamic columns of keys and integers.

Sub rad_collection()
    Dim rw As Long, nc As Long, sTMP As String, v As Long, vTMP As Variant
    Dim i As Long, iNumKeys As Long, iNumInts As Long
    Dim dRADs As New Scripting.Dictionary

    dRADs.CompareMode = vbTextCompare
    iNumKeys = 5    'possibly calculated by num text (see below)
    iNumInts = 2    'possibly calculated by num ints (see below)

    With ThisWorkbook.Sheets("Sheet4").Cells(1, 1).CurrentRegion
        'iNumKeys = Application.CountA(.Rows(2)) - Application.Count(.Rows(2))  'alternate count of txts
        'iNumInts = Application.Count(.Rows(2))    'alternate count of ints
        For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).row
                vTMP = .Cells(rw, 1).Resize(1, iNumKeys).Value2
                sTMP = Join(Application.Index(vTMP, 1, 0), Chr(183))
                If Not dRADs.Exists(sTMP) Then
                    dRADs.Add Key:=sTMP, Item:=Join(Application.Index(.Cells(rw, iNumKeys + 1).Resize(1, iNumInts).Value2, 1, 0), Chr(183))
                Else
                    vTMP = Split(dRADs.Item(sTMP), Chr(183))
                    For v = LBound(vTMP) To UBound(vTMP)
                        vTMP(v) = vTMP(v) + .Cells(rw, iNumKeys + 1 + v).Value2
                    Next v
                    dRADs.Item(sTMP) = Join(vTMP, Chr(183))
                End If

        Next rw

        rw = 1
        nc = iNumKeys + iNumInts + 1
        .Cells(rw, nc + 1).CurrentRegion.ClearContents  'clear previous
        .Cells(rw, nc + 1).Resize(1, nc - 1) = .Cells(rw, 1).Resize(1, nc - 1).Value2
        For Each vTMP In dRADs.Keys
            'Debug.Print vTMP & "|" & dRADs.Item(vTMP)
            rw = rw + 1
            .Cells(rw, nc + 1).Resize(1, iNumKeys) = Split(vTMP, Chr(183))
            .Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts) = Split(dRADs.Item(vTMP), Chr(183))
            .Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts) = _
              .Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts).Value2
        Next vTMP
    End With

    dRADs.RemoveAll: Set dRADs = Nothing

End Sub

Just run the macro against the numbers you have provided as samples. I've assumed some form of column header labels in the first row. The dictionary object is populated and duplicates in the combined identifiers have their numbers summed. All that is left is to split them back up and return them to the worksheet in an unused area.

    

Location of Microsoft Scripting Runtime - In the Visual Basic Editor (aka VBE) choose Tools ► References (Alt+T,R) and scroll down a little more than halfway to find it.