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