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
Reply With Quote
