Moving data from a column to row and appending data to it

[dawnoharding]

I have a customer database from our system. The customer database is company details for example column A is company reference, column B is company name, column C is address etc. The last columns contain multiple email addresses for example column D, E, F etc. So all the email addresses for the company are listed in the same row. Some rows will have a couple of addresses and some go up to about twenty email addresses.

For my email management software, I can only have one email address per row when importing. I therefore need to be able to create a way to create a row for each email address and pull the company details in to the new row.

I am sure there must be a way but can't work it out.

Hope it makes sense any help would be great

 

[mumps]

It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[dawnoharding]

Sorry at home without access to computer plus has customer data within so can't share.


Hopefully this will help
Currently have this (a more simplified version)

Col A. Col B. Col C. Col D. Col E
No. Name. Email1. Email2. Email3
123. Com. E1@e.com E2@e.com e3@e.com
124 Dom. F1@f.com f2@f.com f3@f.com
125 Eom. G1@g.com
126 Fom. P1@pp.com pl2@pp.com
127. Gom. E@ge.com F@ge.com H@ge.com


And need to change it to something like this

Col A. Col B. Col C.
No. Name. Email1.
123. Com. E1@e.com
123. Com. E2@e.com
123. Com. e3@e.com
124 Dom. F1@f.com
124 Dom. f2@f.com
124 Dom. f3@f.com
125 Eom. G1@g.com
126 Fom. P1@pp.com
126 Fom. pl2@pp.com
127. Gom. E@ge.com
127. Gom. F@ge.com
127. Gom. H@ge.com

 

[mumps]

In which column is the first email address for each company?

 

[dawnoharding]

In which column is the first email address for each company?

It would be the fifth column so column E

 

[mumps]

The result will be placed in Sheet2. Change the sheet names (in red) to suit your needs.

Sub TransposeData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, lCol As Long, rng As Range, cnt As Long
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    With srcWS
        For Each rng In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
            lCol = .Cells(rng.Row, .Columns.Count).End(xlToLeft).Column
            cnt = lCol - 4
            With desWS
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(cnt, 4).Value = rng.Resize(, 4).Value
                .Cells(.Rows.Count, "E").End(xlUp).Offset(1).Resize(cnt).Value = WorksheetFunction.Transpose(rng.Offset(, 4).Resize(, cnt))
            End With
        Next rng
    End With
    Application.ScreenUpdating = True
End Sub

 

[jolivanes]

Not all that much different from Mumps. Just slightly shorter (as if that makes a difference!!!!).
Starts email addresses at the 3rd Column. Change as required.

Sub Or_So_Maybe()
Dim c As Range, sh1 As Worksheet, sh2 As Worksheet, amt As Long
Set sh1 = Worksheets("Sheet2")
Set sh2 = Worksheets("Sheet3")
    For Each c In sh1.Range("A2:A" & sh1.Cells(Rows.Count, 1).End(xlUp).Row)
    amt = sh1.Cells(c.Row, sh1.Columns.Count).End(xlToLeft).Column - 2
        With sh2.Cells(Rows.Count, 3).End(xlUp).Offset(1).Resize(amt)
            .Value = Application.Transpose(c.Offset(, 2).Resize(, amt).Value)
            .Offset(, -2).Resize(, 2).Value = c.Resize(, 2).Value
        End With
    Next c
End Sub