VBA or Macro

[lyn5339]

Hello,
i have a project where i am pretty sure i need VBA but i am in the process of learning. basically i have about 20,000 rows of datas and text and i have how it is formated below. if there is more then one e-mail address in column B(which can be sepearted by either a space,comma,or semicolon) then i need to insert a new row directly below the original for each e-mail address. and in the new row all information needs copied from all cells in original row except the e-mail which obviously will be the new e-mail. so i am tryiong to create coding to run that will recognize that there needs to be a new row for all the e-mail addresses in the original cell. any advice would help because i am racking my brain. thank you

Before:

Column A	Column B	Column C	Column D	Column E
Name	e-mail1 e-mail2, e-mail3; e-mail4	Date	Company	Location
After:
Column A	Column B	Column C	Column D	Column E
Name	e-mail1	Date	Company	Location
Name	e-mail2	Date	Company	Location
Name	e-mail3	Date	Company	Location
Name	e-mail4	Date	Company	Location

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

 

[James Snyder]

That is a complex problem. Obviously, there will be a looping structure that checks each cell in the column. The best way I can think of to do this would be to parse the contents into an array looking for a space, a comma or a semicolon using an INSTR(). That could be done in a do/while wrapped around the checking of the separator.
Then for the email address, you could use a count of emails returned to add a row below, insert the contents of the rest of the cells, and add the email by looping for a count and using the loop index to identify which email to add.

 

[JoeMo]

Try this. Assumes your names are in column A starting in A2 and email addresses in column B starting in B2.

Sub lyn5339()
Dim lR As Long, R As Range, c As Range, sV As Variant, i As Long, j As Long
lR = Range("A" & Rows.Count).End(xlUp).Row
Set R = Range("A2", "A" & lR)
For i = R.Rows.Count To 1 Step -1
    If InStr(Trim(R.Cells(i, 1).Offset(0, 1)), " ") Or InStr(Trim(R.Cells(i, 1).Offset(0, _
        1)), ",") Or InStr(Trim(R.Cells(i, 1).Offset(0, 1)), ";") Then
        R.Cells(i, 1).Offset(0, 1).Value = Replace(R.Cells(i, 1).Offset(0, 1), ",", " ")
        R.Cells(i, 1).Offset(0, 1).Value = Replace(R.Cells(i, 1).Offset(0, 1), ";", " ")
        R.Cells(i, 1).Offset(0, 1).Value = WorksheetFunction.Trim(R.Cells(i, 1).Offset(0, 1).Value)
        sV = Split(R.Cells(i, 1).Offset(0, 1).Value, " ")
        R.Cells(i, 1).Offset(1, 0).Resize(UBound(sV), 2).Insert shift:=xlDown
        For j = 0 To UBound(sV)
            R.Cells(i, 1).Offset(j, 0).Value = R.Cells(i, 1).Value
            R.Cells(i, 1).Offset(j, 1).Value = sV(j)
        Next j
    End If
Next i
End Sub

 

[lyn5339]

Wow! Thank you both for the response and that divided up the e-mails perfectly. it did not copy columns C through H("date,company,activity,active indicator,invoice,account") like it did for the name so would i just those as ranges for R?

 

[James Snyder]

Exactly. "C:H"

 

[lyn5339]

i was getting an error dealing invalid property name with Range highlighted so i thought maybe i could include "C:H" into 1R range and it worked for the name and e-mail again but still nothing for C:H. almost like it ignored just those columns.
Here is what i had in there:
lR = Range("A" & "C:H" & Rows.Count).End(xlUp).Row
Set R = Range("A2", "A" & lR)

 

[JoeMo]

Wow! Thank you both for the response and that divided up the e-mails perfectly. it did not copy columns C through H("date,company,activity,active indicator,invoice,account") like it did for the name so would i just those as ranges for R?

This will include columns C:H (assuming you just want to repeat the values therein for each separate email address.

Sub lyn5339()
Dim lR As Long, R As Range, c As Range, sV As Variant, i As Long, j As Long
lR = Range("A" & Rows.Count).End(xlUp).Row
Set R = Range("A2", "A" & lR)
Application.ScreenUpdating = False
For i = R.Rows.Count To 1 Step -1
    If InStr(Trim(R.Cells(i, 1).Offset(0, 1)), " ") Or InStr(Trim(R.Cells(i, 1).Offset(0, _
        1)), ",") Or InStr(Trim(R.Cells(i, 1).Offset(0, 1)), ";") Then
        R.Cells(i, 1).Offset(0, 1).Value = Replace(R.Cells(i, 1).Offset(0, 1), ",", " ")
        R.Cells(i, 1).Offset(0, 1).Value = Replace(R.Cells(i, 1).Offset(0, 1), ";", " ")
        R.Cells(i, 1).Offset(0, 1).Value = WorksheetFunction.Trim(R.Cells(i, 1).Offset(0, 1).Value)
        sV = Split(R.Cells(i, 1).Offset(0, 1).Value, " ")
        R.Cells(i, 1).Offset(1, 0).Resize(UBound(sV), 8).Insert shift:=xlDown
        For j = 0 To UBound(sV)
            R.Cells(i, 1).Offset(j, 0).Value = R.Cells(i, 1).Value
            R.Cells(i, 1).Offset(j, 2).Resize(1, 6).Value = R.Cells(i, 1).Offset(0, 2).Resize(1, 6).Value
            R.Cells(i, 1).Offset(j, 1).Value = sV(j)
        Next j
    End If
Next i
End Sub

 

[lyn5339]

Thank you that worked out perfectly!

 

[lyn5339]

seems like i spoke to soon. i tested it on first about 50 rows which worked and then once i tryed the original file, i recieved an error and once in the debugging it showed me the line below. i hovered over to see where the issue was and it seems to tell me "xlDown=-4121", have you ever seen this before? is just because of the large amount of rows(130,000)

R.Cells(i, 1).Offset(1, 0).Resize(UBound(sV), 8).Insert shift:=xlDown

 

[JoeMo]

seems like i spoke to soon. i tested it on first about 50 rows which worked and then once i tryed the original file, i recieved an error and once in the debugging it showed me the line below. i hovered over to see where the issue was and it seems to tell me "xlDown=-4121", have you ever seen this before? is just because of the large amount of rows(130,000)

R.Cells(i, 1).Offset(1, 0).Resize(UBound(sV), 8).Insert shift:=xlDown

Likely that you have enough data that you have used all rows. Excel will not allow shift down if it means going off the bottom of the sheet. Can you break the data into two (or more) parts each on a different sheet and run the macro on each sheet separately?