Comma delimited list cell to new row code help

Hello,

I am trying to split any cells with multiple entries, separated by a comma, to new rows. Then I need to copy the information from the original row to the newly created rows. I have a code that will work on a test workbook, but when I run it on the workbook I the code for, it will not separate the data. Here is the code and I will attach the two file also.

Option Explicit
Public Col As String
Public daSting As String, Z As Long, daRow As Long
Public stringLen, daAnsw, X


Sub Expand_Data()
    Call movecolQ
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "Expanded"
    Sheets("DATA").Cells.Copy
    ActiveSheet.Range("A1").PasteSpecial
    Call CountCommas

End Sub


Sub CountCommas()
    Sheets("Expanded").Select
    daRow = Application.CountA(ActiveSheet.Range("A:A"))
    For Z = 1 To daRow              'How many rows to work on
        daSting = Cells(Z, 1)       'Get string
        stringLen = Len(daSting)        'Length of String
        For X = 1 To stringLen          'Increment thru
            Select Case Mid(daSting, X, 1)
            Case ","                'If it is a comma
                daAnsw = daAnsw + 1    'Add 1 to list
            Case Else           'Do nothing
            End Select
        Next
        Cells(Z, 25) = daAnsw            'Write the answer
        daAnsw = 0                      'Reset counter
    Next
    Call InsertRows
End Sub

Sub InsertRows()
    Dim lRows As Long
    Dim iCell As Range
    Dim rng As Range
    Dim LR As Long

    Application.ScreenUpdating = False
    LR = Range("Y" & Rows.Count).End(xlUp).Row

    Set rng = Range("Y2:Y" & LR)

    For Each iCell In rng
        If Not iCell = 0 Then
            lRows = iCell
            iCell = 0
            iCell.Resize(lRows, 1).EntireRow.Insert
            iCell.EntireRow.Copy
            iCell.Offset(0, 0).EntireRow.Select
            Range(iCell, iCell.Offset(-lRows, 0)).EntireRow.PasteSpecial
            Col = Right(iCell.Offset(-lRows, 0).Address, 2)

            Call SplitCells

        End If
    Next
    Columns(25).ClearContents
    Call origcolQ
    Call firstpagecolQ
    Application.ScreenUpdating = True
    Call msgbox1
    
    
End Sub

Sub SplitCells()
    Dim i As Long
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        Sheets("Expanded").Range("A" & Col).Select
        For i = 1 To Selection.Rows.Count
            Dim splitValues As Variant
            splitValues = Split(Selection.Rows(i).Value, ",")
            Selection.Rows(i).Resize(UBound(splitValues) - LBound(splitValues) + 1).Value = Application.Transpose(splitValues)
        Next i
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Sub movecolQ()
ActiveSheet.Name = "DATA"
Columns("Q").Copy
Columns("A").Insert
Columns("R").Delete 'or clearcontents
End Sub

 Sub origcolQ()
Columns("A").Copy
Columns("R").Insert
Columns("A").Delete 'or clearcontents
End Sub

 Sub msgbox1()
    MsgBox "Done"
End Sub
 
 Sub firstpagecolQ()
Sheets("DATA").Select
Columns("A").Copy
Columns("R").Insert
Columns("A").Delete 'or clearcontents
Sheets("Expanded").Select
End Sub

Thank you for any tips or suggestions. If you have any questions please ask.
John

Hi John

In this code

Sub CountCommas()
    Sheets("Expanded").Select
    daRow = Application.CountA(ActiveSheet.Range("A:A"))
    For Z = 1 To daRow              'How many rows to work on
        daSting = Cells(Z, 1)       'Get string
        stringLen = Len(daSting)        'Length of String
        For X = 1 To stringLen          'Increment thru
            Select Case Mid(daSting, X, 1)
            Case ","                'If it is a comma
                daAnsw = daAnsw + 1    'Add 1 to list
            Case Else           'Do nothing
            End Select
        Next
        Cells(Z, 25) = daAnsw            'Write the answer
        daAnsw = 0                      'Reset counter
    Next
    Call InsertRows
End Sub

In the file that works, daRow evaluates to 15 and all your coma delimited cells are within that range...so it works. In the file that doesn't work, daRow evaluates to 87 and all the coma delimited cells fall outside that range and aren't getting evaluated.

Welcome to the Forum!

I haven't dug through it in detail, but I notice that the DoesWork workbook has delimited strings in column Q, while Doesn'tWork has numbers (or blanks) in column Q

Hi John
I've some ideas...I'll post back this afternoon.

Hi John

This code has been tested on both books and appears do do as you require. This is the code for CountCommas

Private Sub CountCommas()
    Dim daCell As Range
    Sheets("Expanded").Select
    '    daRow = Application.CountA(ActiveSheet.Range("A:A"))
    For Each daCell In Columns("A:A").SpecialCells(xlConstants)
        '    For Z = 1 To daRow              'How many rows to work on
        daSting = daCell.Text       'Get string
        stringLen = Len(daSting)        'Length of String
        For X = 1 To stringLen          'Increment thru
            Select Case Mid(daSting, X, 1)
            Case ","                'If it is a comma
                daAnsw = daAnsw + 1    'Add 1 to list
            Case Else           'Do nothing
            End Select
        Next
        Cells(daCell.Row, 25) = daAnsw            'Write the answer
        daAnsw = 0                      'Reset counter
    Next
    Call InsertRows
End Sub

And this is the code for InsertRows (you'll see that I changed one line of code)

Sub InsertRows()
    Dim lRows As Long
    Dim iCell As Range
    Dim rng As Range
    Dim LR As Long
    Application.ScreenUpdating = False
    LR = Range("Y" & Rows.Count).End(xlUp).Row
    Set rng = Range("Y2:Y" & LR)
    For Each iCell In rng
        If Not iCell = 0 Then
            lRows = iCell
            iCell = 0
            iCell.Resize(lRows, 1).EntireRow.Insert
            iCell.EntireRow.Copy
            iCell.Offset(0, 0).EntireRow.Select
            Range(iCell, iCell.Offset(-lRows, 0)).EntireRow.PasteSpecial
            Col = iCell.Offset(-lRows, 0).Row
            '            Col = Right(iCell.Offset(-lRows, 0).Address, 2)
            Call SplitCells
        End If
    Next
    Columns(25).ClearContents
    Call origcolQ
    Call firstpagecolQ
    Application.ScreenUpdating = True
    Call msgbox1
 
End Sub

Let me know of issues.

You're welcome John...glad I could help.

NumberOfCommas = Len(aString) - Len(Replace(aString, ",", vbNullString))

@mikerickson

Of course you're right...since I was rewriting that particular part of the code, I should have rewritten it to make it more efficient. Not sure why I didn't...I knew there were better ways. Still learning myself to lead OP's to better solutions...want them to know "what they have works"...but, try this. It's a balance...working on it.