VBA: Input cell data outout in three ways

I have input data in sheet 1 as it appears below and need to get the results in below three ways in separate sheets. Header not included.

Sheet1: Input Data

asdfg1	asdfg1, asdfg1%, asdfg1, asdfg1%
asdfg2	asdfg1#, asdfg1
asdfg3	wxy1#, b-r-a-d-e-1

Sheet R1: Result 1

asdfg1	asdfg1
	asdfg1%
	asdfg1
	asdfg1%
asdfg2	asdfg1#
	asdfg1
asdfg3	wxy1#
	b-r-a-d-e-1

Sheet R2: Result 2

asdfg1	asdfg1
asdfg1	asdfg1%
asdfg1	asdfg1
asdfg1	asdfg1%
asdfg2	asdfg1#
asdfg2	asdfg1
asdfg3	wxy1#
asdfg3	b-r-a-d-e-1

Sheet R3: Result 3

asdfg1	asdfg1, asdfg1%, asdfg1, asdfg1%
asdfg2	asdfg1#, asdfg1
asdfg3	wxy1#, b-r-a-d-e-1

Code:

---

Sub SplitIntoSheets()
    Dim wksActv    As Worksheet
    Dim WksT        As Worksheet
    Dim lLrow      As Long
    Dim Rng        As Range
    Dim LRow        As Long
    Dim varArr      As Variant


    Set wksActv = ActiveSheet


    lLrow = wksActv.Cells(Rows.Count, "A").End(xlUp).Row


    'To Sheet R1
    Set WksT = Worksheets("Sheet R1")
    LRow = 1


    For Each Rng In wksActv.Range("A1:A" & lLrow).Cells
        varArr = Empty


        If Not IsEmpty(Rng.Value) Then
            WksT.Cells(LRow, "A").Value = Rng.Value
            varArr = Split(Rng.Offset(, 1).Value, ",")


            If UBound(varArr) > -1 Then
                varArr = TransposeIt(varArr)
                WksT.Cells(LRow, "B").Resize(UBound(varArr) + 1).Value = varArr
                LRow = LRow + UBound(varArr)
            End If


            LRow = LRow + 1
        End If


    Next Rng


    'To Sheet R2
    Set WksT = Worksheets("Sheet R2")
    LRow = 1


    For Each Rng In wksActv.Range("A1:A" & lLrow).Cells
        varArr = Empty


        If Not IsEmpty(Rng.Value) Then
            WksT.Cells(LRow, "A").Value = Rng.Value
            varArr = Split(Rng.Offset(, 1).Value, ",")


            If UBound(varArr) > -1 Then
                varArr = TransposeIt(varArr)
                WksT.Cells(LRow, "B").Resize(UBound(varArr) + 1).Value = varArr
                WksT.Cells(LRow, "A").Resize(UBound(varArr) + 1).Value = Rng.Value


                LRow = LRow + UBound(varArr)


            End If


            LRow = LRow + 1
        End If


    Next Rng


    'To Sheet R3
    Set WksT = Worksheets("Sheet R3")
    LRow = 1


    For Each Rng In wksActv.Range("A1:A" & lLrow).Cells
        If Not IsEmpty(Rng.Value) Then
            WksT.Cells(LRow, "A").Resize(, 2).Value = Rng.Resize(, 2).Value
            LRow = LRow + 1
        End If
    Next Rng


End Sub






Function TransposeIt(vData)

    Dim LBound2    As Long


    LBound2 = -1


    If IsArray(vData) Then
        ' test for 1D array
        On Error Resume Next
        LBound2 = UBound(vData, 2)
        On Error GoTo 0


        With CreateObject("New:{8BD21D20-EC42-11CE-9E0D-00AA006002F3}")
            .Column = vData


            If LBound2 = -1 Then
                ' for 1D, returning the Column will transpose and return 2D array
                TransposeIt = .Column
            Else
                ' for 2D array just return the List
                TransposeIt = .List
            End If
        End With


    End If
End Function

---

Artik

Not working !

What do you think my mechanic will answer if I tell him that my car is "not working"?

Artik