Excel VBA – Combine Values from Multiple Rows into Single Row

microsoft excelvba

I'm looking to combine multiple rows into a single row based on a value in the code column.. I've noticed other questions on here similiar to my question but I cannot seem to extend the range..

Code    Name    Value A Value B Value C Value D Value E
101   Example      #                
101   Example                       
101   Example                     #     
101   Example                            #  
101   Example                                    #
102   Example2                                   #
102   Example2                           #  
102   Example2                    #     
102   Example2            #         
102   Example2     #

So the final result looks like this:

Code    Name    Value A Value B Value C Value D Value E
101    Example     #               #       #       #
102    Example2    #       #       #       #       #

Edit

This is what I've got so far, my plan was to shift the items to the row above before deleting the entire row as one row may have many items.

Dim RowNum, LastRow, Col As Long

RowNum = 2
Col = 3

LastRow = Cells.SpecialCells(xlCellTypeLastCell).row
Range("A2", Cells(LastRow, 7)).Select

For Each row In Selection
    With Cells
        If Cells(RowNum, 1) = Cells(RowNum + 1, 1) Then
            For Each Cell In row
                If Cell > 0 Then
                Cells(RowNum + 1, Col).Copy Destination:=Cells(RowNum, Col)
                Else
                Col = Col + 1
            End If
        Rows(RowNum + 1).EntireRow.Delete
        End If
  End With

RowNum = RowNum + 1

Next row

Best Answer

I'm kind of ashamed of the answer you based your code on. Backup your data and test on a copy!

This should work:

Sub combine()

Dim c As Range
Dim i As Integer

For Each c In Range("A2", Cells(Cells.SpecialCells(xlCellTypeLastCell).Row, 1))
If c = c.Offset(1) And c <> "" Then
       For i = 1 To 6
            If c.Offset(1, i) <> "" Then
                c.Offset(, i) = c.Offset(1, i)
            End If
       Next
       c.Offset(1).EntireRow.Delete
End If

Next

End Sub
Related Question