Expanding columns out into rows with unique criteria

FirstWorldAnalyst

New Member
Joined
Apr 13, 2018
Messages
2
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 NumbersEmail Addresses
10010jo.bob@gmail.com
10011amy.smith@gmail.com
george.robinson@gmail.com
tom.nelson@gmail.com
10012jacob.riely@gmail.com
nathan.brown@gmail.com

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


Into this:

Reservation NumbersEmail Addresses
10010jo.bob@gmail.com
10011amy.smith@gmail.comgeorge.robinson@gmail.comtom.nelson@gmail.com
10012jacob.riely@gmail.comnathan.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!
 

Some videos you may like

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,436
Office Version
  1. 2013
Platform
  1. Windows
See if this will do what you want.

Code:
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
 
Last edited:

jim may

Well-known Member
Joined
Jul 4, 2004
Messages
7,471
I worked up this code...

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
 

Watch MrExcel Video

Forum statistics

Threads
1,108,987
Messages
5,526,069
Members
409,685
Latest member
Davetom

This Week's Hot Topics

Top