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]

My mistake for not looking at it more carefully. The range is expecting a starting cell and an ending cell. Moe's code was working on cells in one column. To expand it, you need nested for loops with the outer loop cycling through the columns with an "if" statement to remove processing of column B. Modifying Moe's code:

Sub lyn5339()
Dim lR As Long, R As Range, c As Range, sV As Variant, i As Long, j As Long, k As Long
lR = Range("A" & Rows.Count).End(xlUp).Row
Set R = Range("A2", "A" & lR)
For k = 1 to 8
    if k = 2 Then k = 3
    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
Next k 
End Sub

 

[lyn5339]

yep! it worked that way. i did not know about those limits. when i split it, it could take roughly 18,000 rowsper sheet and run. these records will come once a month so what i can do is create a macro to run and section the full data out by 18,000 per sheet and then run the macro you created. thank you so much for your expertise, you saved me a solid 2 weeks of work.

 

[JoeMo]

yep! it worked that way. i did not know about those limits. when i split it, it could take roughly 18,000 rowsper sheet and run. these records will come once a month so what i can do is create a macro to run and section the full data out by 18,000 per sheet and then run the macro you created. thank you so much for your expertise, you saved me a solid 2 weeks of work.

Glad I could help. Thanks for the feedback.

 

[JoeMo]

My mistake for not looking at it more carefully. The range is expecting a starting cell and an ending cell. Moe's code was working on cells in one column. To expand it, you need nested for loops with the outer loop cycling through the columns with an "if" statement to remove processing of column B. Modifying Moe's code:

Sub lyn5339()
Dim lR As Long, R As Range, c As Range, sV As Variant, i As Long, j As Long, k As Long
lR = Range("A" & Rows.Count).End(xlUp).Row
Set R = Range("A2", "A" & lR)
For k = 1 to 8
    if k = 2 Then k = 3
    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
Next k 
End Sub

I don't think your modification will work. Please see the modification I posted in post #7 of this thread.

 

[lyn5339]

i have a code below where it sections out 18,000 rows from a "master List" into new sheets and i thought that maybe i could work the coding you made into this code so that as soon it adds the 18,000 rows into a new sheet it runs the e-mail macro. unfortunately i am still getting the error with the "R.Cells(i, 1).Offset(1, 0).Resize(UBound(sV), 8).Insert shift:=xlDown", is it still because of the data limits you said it could be?
Sub seperate_datasheets()
'
' seperate_datasheets Macro
'
' Keyboard Shortcut: Ctrl+s
'
Dim Last_Row As Long
Dim i As Long
Dim Limit As Long
Application.ScreenUpdating = False
Limit = 18000
With Sheets("Sheet1")
Last_Row = .Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To WorksheetFunction.Ceiling(Last_Row / Limit, 1)
Range(.Cells(((i - 1) * Limit) + 1, 1), .Cells((i + 1) * Limit, 10)).Copy
Sheets.Add
ActiveSheet.Paste
Application.Insert "Organize_emails"

Next i

End With
Application.ScreenUpdating = True
End Sub

 

[JoeMo]

i have a code below where it sections out 18,000 rows from a "master List" into new sheets and i thought that maybe i could work the coding you made into this code so that as soon it adds the 18,000 rows into a new sheet it runs the e-mail macro. unfortunately i am still getting the error with the "R.Cells(i, 1).Offset(1, 0).Resize(UBound(sV), 8).Insert shift:=xlDown", is it still because of the data limits you said it could be?

Excel 2007 and later versions have 1,048,576 rows on a worksheet. Your 18,000 records would have to each have on average 59 email addresses to cause the data to overflow the sheet. If that's not the case, then something else is causing the code to bug. If you PM me I will give you an email address where you could send your workbook or a sample of it and I will try to resolve the issue and adapt the code so it splits the data into several sheets and does the reorganizing you want.