Comma delimited list cell to new row code help

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.