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" & 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