Expanding columns out into rows with unique criteria

[FirstWorldAnalyst]

Hi All!

First off, I apologize at my horrible attempt to title this thread - I'm sure there's a much better way to word it. I'm pretty stumped on this one. I'm working with a fairly large database (~5K rows) of reservation numbers & email addresses. Please forgive my poor attempt at describing my problem:

I have two columns to work with, "Reservation Numbers" & "Email Addresses". If there's one email address per reservation number, they'll line up in the same row. However, if there are two or more emails assigned to a reservation number, an extra row is inserted with a (blank) in the reservation number column. I'm trying to branch out "Emails" column into new rows but also aligned with the correct "Reservation Number" row.

I'm trying to turn this:

Reservation Numbers	Email Addresses
10010	jo.bob@gmail.com
10011	amy.smith@gmail.com
	george.robinson@gmail.com
	tom.nelson@gmail.com
10012	jacob.riely@gmail.com
	nathan.brown@gmail.com

<colgroup><col><col></colgroup><tbody>
</tbody>

Into this:

Reservation Numbers	Email Addresses
10010	jo.bob@gmail.com
10011	amy.smith@gmail.com	george.robinson@gmail.com	tom.nelson@gmail.com
10012	jacob.riely@gmail.com	nathan.brown@gmail.com

<colgroup><col><col span="2"><col></colgroup><tbody>
</tbody>

I hope this all makes sense. Thank you for taking the time to read through and I look forward to any/all replies!

Thank you, again!

 

[JLGWhiz]

See if this will do what you want.

Sub t()
Dim i As Long
    For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
        If Cells(i, 1) = "" Then
            Cells(i, 2).Cut Cells(i, 1).End(xlUp).End(xlToRight).Offset(, 1)
            Rows(i).Delete
        End If
    Next
End Sub

 

[jim may]

I worked up this code...

Sub Foo()
Dim i As Long
j = 0
    For i = 3 To Cells(Rows.Count, 2).End(xlUp).Row  ' to row 12
        If Cells(i, 1) = "" Then
        j = j + 1
            Cells(i, 2).Copy
            Cells(i - j, 2 + j).PasteSpecial _
            Paste:=xlPasteValues
        Else
        j = 0
        End If
    Next
Application.CutCopyMode = False
End Sub