VBA: Input cell data outout in three ways

[jadgon]

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

[Artik]

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

[jadgon]

Not working !

[Artik]

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

Artik