Split two columns into separate rows, without losing common identifiers

[tRiglyc]

Hello,

I have a spreadsheet with about 2500 rows that contains contact e-mails for companies. To give you a rough example, it's formatted kind of like this:

Excel 2007

Company	State	Email	Email	Email
ABC Company	OH	email1@abc.com	email2@abc.com	email3@abc.com
XYZ Company	NY	email1@XYZ.com	email2@XYZ.com	email3@XYZ.com

<tbody>
</tbody>

I need to put each e-mail address on its own row, without losing the company info that goes with it. So I'd like it to look like this.

Excel 2007

Company	State	Email
ABC Company	OH	email1@abc.com
ABC Company	OH	email2@abc.com
ABC Company	OH	email3@abc.com
XYZ Company	NY	email1@XYZ.com
XYZ Company	NY	email2@XYZ.com
XYZ Company	NY	email3@XYZ.com

<tbody>
</tbody>

I'm guessing I'll need a macro to do this, but I can't find anything for this exact scenario. (I'm also a complete rookie with macros.) Any help will be greatly appreciated.

Thanks!

 

[Andrew Poulsom]

Welcome to MrExcel.

Try:

Sub Test()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim ShNew As Worksheet
    Dim x As Integer
    Dim r As Integer
    Dim c As Integer
    Set Sh = Worksheets("Sheet1")
    Set Rng = Sh.Range("A1").CurrentRegion
    Set ShNew = Worksheets.Add
    x = 1
    With ShNew
        .Cells(x, 1) = Sh.Cells(x, 1)
        .Cells(x, 2) = Sh.Cells(x, 2)
        .Cells(x, 3) = "Email"
    End With
    x = x + 1
    For r = 2 To Rng.Rows.Count
        For c = 3 To Rng.Columns.Count
            ShNew.Cells(x, 1) = Rng.Cells(r, 1)
            ShNew.Cells(x, 2) = Rng.Cells(r, 2)
            ShNew.Cells(x, 3) = Rng.Cells(r, c)
            x = x + 1
        Next c
    Next r
End Sub

 

[tRiglyc]

That's phenomenal - worked perfectly! Can't even imagine how long it would have taken me to figure that out on my own.

Thanks a lot, Andrew!