Copy and Pasting- is there a short cut?

[JenChism]

I have an excel sheet that has headers columns for company name (A1), company address (B1), company website (C1) and email addresses (D1). The last field (D1) contains multiple addresses which I have been able to extract into additional columns to the right of the exisiting columns (the number of additional columns will vary row to row depending how many emails were in the (D1) column). So each line now shows the company name in A1 with each field in its own cell to the right with the emails now each having their own cell. I have an entire speadsheet set up this way. What I need to know is if there is a way to get all of the emails currently showing on the same row to be dropped into a new row and get the company information from A1-C1 (company name, address and website) be included on the new row?
Example:
ABC Co. 123 River Rd. www.abc.com jb@abcco.com; jc@abc.com, j2@abc.com
I need to get it to look like this:
ABC Co. 123 River Rd. www.abc.com jb@abcco.com
ABC Co. 123 River Rd. www.abc.com jc@abc.com
ABC Co. 123 River Rd. www.abc.com j2@abc.com
Is there way for me to do this without copying and pasting for hours?
Thank You!
[E-mail address removed by moderator]
251-253-4099

 

[Leith Ross]

Hello JenChism,

This macro will separate will copy the company information, web site, and a single email from the source sheet ("Sheet1") to a new row on the destination sheet ("Sheet2"). You can change the sheet names in the macro to what you will using. Copy and paste this macro code into a new VBA module in your workbook.

NOTE: The macro expects the email addresses to be separated by a semi-colon.

' Poster:  JenChism
' Thread:  http://www.mrexcel.com/forum/showthread.php?t=578025
' Written: September 11, 2011
' Author:  Leith Ross

Sub OneEmailPerRow()

  Dim Cell As Range
  Dim CompanyInfo As Variant
  Dim DstRng As Range
  Dim DstWks As Worksheet
  Dim Emails As Variant
  Dim I As Long
  Dim R As Long
  Dim SrcRng As Range
  Dim SrcWks As Worksheet
  
  ' Choose the Source and Destination sheet names
    Set SrcWks = Worksheets("Sheet1")
    Set DstWks = Worksheets("Sheet2")
    
    ' Automatically setup the Source and Destination ranges
      Set SrcRng = SrcWks.Range("A1").CurrentRegion
      Set DstRng = DstWks.Range("A1")
      
      ' Split the Source data and emails and copy to the Destination
        For Each Cell In SrcRng.Columns(1).Cells
          CompanyInfo = Cell.Resize(1, 3).Value
          Emails = Split(Cell.Offset(0, 3), ";")
          ' Put Company info and a single email on a single row
            For I = 0 To UBound(Emails)
              DstRng.Offset(R, 0).Resize(1, 3).Value = CompanyInfo
              DstRng.Offset(R, 3).Value = Emails(I)
              R = R + 1
            Next I
        Next Cell
              
End Sub

 

[p45cal]

Try this, lots of hard coding, operates on the active sheet:

Sub bah()
LR = Cells(Rows.Count, "A").End(xlUp).Row
For rw = LR To 2 Step -1
    NewRowsNeeded = Cells(rw, Columns.Count).End(xlToLeft).Column - 4
    If NewRowsNeeded > 0 Then
        Rows(rw + 1).Resize(NewRowsNeeded).Insert
        Cells(rw, 1).Resize(, 3).Copy Cells(rw + 1, 1).Resize(NewRowsNeeded)
        Cells(rw, "E").Resize(, NewRowsNeeded).Copy
        Cells(rw + 1, "D").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        Cells(rw, "E").Resize(, NewRowsNeeded).ClearContents
    End If
Next rw
End Sub

 

[JenChism]

Thank you very much for the insight, I will repost asap to let you know if it worked. I am a novice at macros, but think I know how to use the info you guys gave me. I am excited that it IS possible to do this. Thank you both for your responses!