Moving Multiple Rows of Data to Single Row

[branchard]

Let me see if I can accurately describe my problem! I have 9 columns on my spreadsheet: ID, Name, Plan1, Plan2, Plan3, Plan4, Plan5, Plan6, Plan7. I want to look at the ID column. If the #(s) are the same, I want to move all the information from rows 2-? to row 1.

For instance, here is a group with 6 rows (3 columns):
[TABLE="width: 507"]
<TBODY>[TR]
[TD]12345[/TD]
[TD]ABC - GRANDFATHERED[/TD]
[TD]MBSW8883</SPAN>[/TD]
[/TR]
[TR]
[TD]12345</SPAN>[/TD]
[TD]ABC[/TD]
[TD]MBSW8884</SPAN>[/TD]
[/TR]
[TR]
[TD]12345</SPAN>[/TD]
[TD]ABC</SPAN>[/TD]
[TD]MBSWQ034</SPAN>[/TD]
[/TR]
[TR]
[TD]12345</SPAN>[/TD]
[TD]ABC</SPAN></SPAN>[/TD]
[TD]DDCP0088</SPAN>[/TD]
[/TR]
[TR]
[TD]12345</SPAN>[/TD]
[TD]ABC</SPAN></SPAN>[/TD]
[TD]DDCP0089</SPAN>[/TD]
[/TR]
[TR]
[TD]12345</SPAN>[/TD]
[TD]ABC</SPAN>[/TD]
[TD]VEMVMC23</SPAN>[/TD]
[/TR]
</TBODY><COLGROUP><COL><COL><COL></COLGROUP>[/TABLE]


I want to easily move the information in row 2-6 (column 3) to new cells on row 1. Does that make sense?

So I want it to look like this:
[TABLE="width: 948"]
<TBODY>[TR]
[TD]12345[/TD]
[TD]ABC</SPAN></SPAN>[/TD]
[TD]MBSW8883</SPAN>[/TD]
[TD]MBSW8884</SPAN>[/TD]
[TD]MBSWQ034</SPAN>[/TD]
[TD][/TD]
[TD]DDCP0088</SPAN>[/TD]
[TD]DDCP0089</SPAN>[/TD]
[TD]VEMVMC23</SPAN>[/TD]
[/TR]
</TBODY><COLGROUP><COL><COL><COL><COL><COL><COL><COL span=2><COL></COLGROUP>[/TABLE]


Is there an easy way to do this?

Thanks,
Branchard

 

[jeffmb]

If I understand correctly what you are trying to do, I think the following code will work for you:

Option Explicit
Dim Flg As Integer
Dim r As Double
Dim c As Integer
Sub Plans_Row()
    Flg = 0
    r = 2
    c = 4
    Application.ScreenUpdating = False
    Do Until Flg = 1
        If IsEmpty(Cells(r + 1, 1)) Then    ' No more lines
            Flg = 1
        ElseIf Cells(r, 1).Value = Cells(r + 1, 1).Value Then
            Cells(r, c).Value = Cells(r + 1, 3).Value
            c = c + 1
            Rows(r + 1).Delete
        Else
            r = r + 1
            c = 4
        End If
    Loop
    Application.ScreenUpdating = True
End Sub