splitting cell data into columns

Sub SplitRanges()
Dim iCol As Integer, iPtr As Integer, iRangePtr As Integer
Dim lRange(1 To 2) As Long
Dim WS As Worksheet
Dim R As Range
Dim vCur As Variant
Dim sChar As String, sElement As String

Set WS = Sheets("Sheet1")
For Each R In WS.Range("D2:D" & WS.Cells(Rows.Count, 4).End(xlUp).Row)
    iCol = 0
    vCur = WorksheetFunction.Substitute(R.Value, " ", "")
    sElement = ""
    iRangePtr = 1
    lRange(1) = 0
    lRange(2) = 0
    For iPtr = 1 To Len(vCur)
        sChar = Mid$(vCur, iPtr, 1)
        Select Case sChar
        Case "-"
            If iRangePtr< 2 Then
                iRangePtr = iRangePtr + 1
                lRange(2) = 0
            End If
        Case ","
            iRangePtr = 1
            Do
                iCol = iCol + 1
                R.Offset(0, iCol).Value = lRange(1)
                lRange(1) = lRange(1) + 1
            Loop Until lRange(1) > lRange(2)
            lRange(1) = 0
            lRange(2) = 0
        Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9"
            lRange(iRangePtr) = lRange(iRangePtr) * 10 + sChar
            If iRangePtr = 1 Then lRange(2) = lRange(1)
        End Select
    Next iPtr
    Do
        iCol = iCol + 1
        R.Offset(0, iCol).Value = lRange(1)
        lRange(1) = lRange(1) + 1
    Loop Until lRange(1) > lRange(2)
Next R

End Sub