Duplicate Entire Row where Comma Exists

[tinamiller1]

I have several workbooks that have 52 columns and 5000 rows. I receive these on a weekly basis and have some VBA code to clean the data in order to get all the rows distinct so I can import to my SQL Server. The VBA I have now gets these workbooks to a certain point but then I have to manually do a bit of clean-up since I cannot get my VBA to work to copy an entire row based on a column that has a comma. Example date:

ID State Segment AccountID
PG1 CA National 1000000
PG2 CA National 1000100
PG3 CA National 1001001, 1001002
PG4 NY Local 5555055
PG5 NY Individual IND190
PG6 NY National 5555056, 5555057, 5555058, 5555059



So in the example above, I would want after the code is run, the information to look like this:

ID State Segment AccountID
PG1 CA National 1000000
PG2 CA National 1000100
PG3 CA National 1001001
PG3 CA National 1001002
PG4 NY Local 5555055
PG5 NY Individual IND190
PG6 NY National 5555056
PG6 NY National 5555057
PG6 NY National 5555058
PG6 NY National 5555059

Here is the code I have but I cannot figure out how to code the comma.



Sub Main()
'Add rows when , is in cell I to split the accountID into row so row is distinct
Dim cell As Range: Application.ScreenUpdating = False
Set cell = Range("I" & Rows.Count).End(xlUp) ' Last cell in column I
Do
Application.StatusBar = "Processing row " & cell.Row
AddRows cell: If cell.Row = 1 Then Exit Do
Set cell = cell.Offset(-1): If cell.Row Mod 20 = 0 Then DoEvents
Loop
Application.StatusBar = False
End Sub
Sub AddRows(ByRef cell As Range)
If cell = 1 Then cell.Next = 1: Exit Sub
If cell < 2 Or Trim(cell.Offset(1)) = "" Then Exit Sub
cell(1, 2) = 1: Cols = cell.Parent.UsedRange.Columns.Count - 2
For i = 1 To cell - 1
cell(2, 1).EntireRow.Insert: cell(2, 2) = cell - i + 1
Next
cell(1, 3).Resize(cell, Cols).FillDown
End Sub

[tinamiller1]

Here is the answer:



Sub Test()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim ID As Range
Dim SplitID As Variant
Dim counter As Long
Dim x As Long
x = 1
For Each ID In Range("D2:D" & LastRow)
If ID Like "*,*" Then
SplitID = Split(ID, ",")
For counter = 0 To UBound(SplitID)
Rows(ID.Row + 1 + counter).EntireRow.Insert
Range("A" & ID.Row & ":C" & ID.Row).Copy Range("A" & ID.Row + x)
Range("D" & ID.Row + x) = SplitID(counter)
x = x + 1
Next counter
Rows(ID.Row).EntireRow.Delete
End If
x = 1
Next ID
Application.ScreenUpdating = True
End Sub

[Kenneth Hobs]

Good for you!

Since I did it anyway...

Sub SplitByCommasAndAddRows() Dim r As Range, c As Range, cc As Range
Dim a() As String, i As Integer, j As Integer
Dim lc As Long, lr As Long

'http://vbaexpress.com/kb/getarticle.php?kb_id=1035
SpeedOn
On Error GoTo EndSub

Set cc = Range("D" & Rows.Count).End(xlUp)
Set r = Range("D2", cc)
For lr = cc.Row - 1 To 1 Step -1
Set c = r(lr)
a() = Split(c.Value, ",")
i = UBound(a)
If i = 0 Then GoTo nextLR

lc = c.Row
Range("A" & lc & ":" & "D" & lc).Copy
Range("A" & lc + 1 & ":" & "D" & lc + i).Insert Shift:=xlDown

For j = 0 To i
Range("D" & lc + j).Value = a(j)
Next j
nextLR:
Next lr


EndSub:
SpeedOff
Application.CutCopyMode = False
End Sub

[westconn1]

For Each ID In Range("D2:D" & LastRow)as you are inserting rows, rows below the original lastrow will not be processed
probably better to process entire column, exit on empty cell

this was my take on it

For Each cel In Range("d:d")
If IsEmpty(cel) Then Exit For
If InStr(cel, ",") Then
ar = Split(cel, ",")
cel.Offset(1).Resize(UBound(ar)).EntireRow.Insert
cel.Value = ar(0)
cel.EntireRow.Copy
For i = 1 To UBound(ar)
cel.Offset(i, -3).PasteSpecial
cel.Offset(i).Value = ar(i)
Next
Application.CutCopyMode = False
End If
Next