Microsoft Excel – How to Extract Group of Same Rows and Their Values into Columns

It's a pretty rough macro but

Option Explicit

Sub CombineRowsRevisited()

'c is a CELL or a range
Dim c As Range
'i is a number
Dim i As Integer

'for each CELL in this range
For Each c In Range("A2", Cells(Cells.SpecialCells(xlCellTypeLastCell).Row, 1))
'if the CELL is the same as the cell to the right AND
'if the cell 4 to the right is the same as the cell below that one
If c = c.Offset(1) And c.Offset(, 4) = c.Offset(1, 4) Then
            'then make the cell 3 to the right the same as the cell below it
            c.Offset(, 3) = c.Offset(1, 3)
            'and delete the row below the CELL
            c.Offset(1).EntireRow.Delete
End If

Next

End Sub

This would be easier to understand given the above

Sub CombineRowsRevisitedAgain()
    Dim myCell As Range
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row

    For Each myCell In Range(Cells("A2"), Cells(lastRow, 1))
        If (myCell = myCell.Offset(1)) And (myCell.Offset(0, 4) = myCell.Offset(1, 4)) Then
            myCell.Offset(0, 3) = myCell.Offset(1, 3)
            myCell.Offset(1).EntireRow.Delete
        End If
    Next
End Sub

However, depending on the problem, it might be better to step -1 on a row number so nothing gets skipped.

Sub CombineRowsRevisitedStep()
    Dim currentRow As Long
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row

    For currentRow = lastRow To 2 Step -1
        If Cells(currentRow, 1) = Cells(currentRow - 1, 1) And _
        Cells(currentRow, 4) = Cells(currentRow - 1, 4) Then
            Cells(currentRow - 1, 3) = Cells(currentRow, 3)
            Rows(currentRow).EntireRow.Delete
        End If
    Next

End Sub

Applying this Very Good reference to your Q , here is my version.. Assuming the said data is in A1:B21.

1. Select column A and copy it to column to D (empty column). Use Data > remove duplicates , to get unique values from the list. We'll get in D1:D7 :

D1 ---> Category D2 ---> Toll D3 ---> DEF D4 ---> Fax D5 ---> Scale D6 ---> Adv. Fee D7 ---> Oil

2. Then select the unique values, copy. then r-click on F1 and choose Transpose. (It'll paste the copied column data as rows.. so in F1:K1 we'll get :

F1 ---> Toll G1 ---> DEF H1 ---> Fax I1 ---> Scale J1 ---> Adv. Fee K1 ---> Oil

3. In F2 put this and press Ctrl + Shift + Enter :

=IFERROR(INDEX($B:$B,SMALL(IF($A:$A=F$1,ROW($B:$B)-MIN(ROW($B:$B))+1),$E2)),"")

4. Then drag it until K9. Done.

Hope it helps.. (: