Excel Macro to Split Multiple Columns into rows

[cali-novice]

I'm looking for a macro to split a table which looks like this:



Row1
aa
tom,dick,harry
clancy,tracy,macy
x1,x2,x3


Row2
bb
mary
berry
z1


Row3
cc
jill,bill
tracy,murray
y1,y2



To one which looks like this:


1
aa
tom
clancy
x1


2
aa
dick
tracy
x2


3
aa
harry
macy
x3


4
bb
mary
berry
z1


5
cc
jill
tracy
y1


6
cc
bill
murray
y2



Thanks!

[LalitPandey87]

Here you go:

*Change data range accordingly



Option Explicit


Sub lmpTest()


Dim wksSht As Worksheet
Dim varRawData() As Variant
Dim lngLoop As Long
Dim lngLoop1 As Long
Dim lngCol As Long
Dim lngCount As Long
Dim lngTotalCol As Long
Dim lngTotalSplit As Long
Dim varFinalData() As Variant

Set wksSht = ThisWorkbook.ActiveSheet
varRawData = wksSht.Range("$A$1:$D$3").Value
lngCount = 0
lngCol = 0
Erase varFinalData
lngTotalCol = UBound(varRawData, 2)
For lngLoop = LBound(varRawData) To UBound(varRawData)
If InStr(varRawData(lngLoop, 2), ",") Then
If lngCount = 0 Then
lngTotalSplit = UBound(Split(varRawData(lngLoop, 2), ",")) + 1
lngCount = lngTotalSplit
lngCol = 1
Else
lngTotalSplit = UBound(Split(varRawData(lngLoop, 2), ",")) + 1
lngCount = UBound(varFinalData, 2) + lngTotalSplit
lngCol = UBound(varFinalData, 2) + 1
End If
ReDim Preserve varFinalData(1 To lngTotalCol, 1 To lngCount)
For lngLoop1 = 0 To lngTotalSplit - 1
varFinalData(1, lngCol + lngLoop1) = varRawData(lngLoop, 1)
varFinalData(2, lngCol + lngLoop1) = Split(varRawData(lngLoop, 2), ",")(lngLoop1)
varFinalData(3, lngCol + lngLoop1) = Split(varRawData(lngLoop, 3), ",")(lngLoop1)
varFinalData(4, lngCol + lngLoop1) = Split(varRawData(lngLoop, 4), ",")(lngLoop1)
Next lngLoop1
Else
If lngCount = 0 Then
lngCount = 1
Else
lngCount = UBound(varFinalData, 2) + 1
End If
ReDim Preserve varFinalData(1 To lngTotalCol, 1 To lngCount)
lngCol = lngCount
varFinalData(1, lngCol) = varRawData(lngLoop, 1)
varFinalData(2, lngCol) = varRawData(lngLoop, 2)
varFinalData(3, lngCol) = varRawData(lngLoop, 3)
varFinalData(4, lngCol) = varRawData(lngLoop, 4)
End If
Next lngLoop
varFinalData = Application.Transpose(varFinalData)
With wksSht
.Range("G1").Resize(, lngTotalCol).EntireColumn.ClearContents
.Range("G1").Resize(UBound(varFinalData), UBound(varFinalData, 2)).Value2 = varFinalData
End With

Set wksSht = Nothing
Erase varRawData
lngLoop = Empty
lngLoop1 = Empty
lngCol = Empty
lngCount = Empty
lngTotalCol = Empty
lngTotalSplit = Empty
Erase varFinalData


End Sub

[snb]

or

Sub M_snb()
sn = Cells(1).CurrentRegion
ReDim sp(UBound(sn) * 3, 3)

y = 0
For j = 1 To UBound(sn)
st = Split(sn(j, 2), ",")
For jj = 0 To UBound(st)
sp(y, 0) = sn(j, 1)
sp(y, 1) = st(jj)
sp(y, 2) = Split(sn(j, 3), ",")(jj)
sp(y, 3) = Split(sn(j, 4), ",")(jj)
y = y + 1
Next
Next

Cells(10, 1).Resize(UBound(sp) + 1, 4) = sp
End Sub