VBA to seperate and transpose data into rows [duplicate] - excel

Question

This question already has answers here:
Split comma separated entries to new rows [closed]
(2 answers)
Closed 1 year ago.
I currently have this data in a sheet
Col A Col B Col C
1 A angry birds, gaming
2 B nirvana,rock,band
What I want to do is split the comma separated entries in the third column and insert in new rows like below:
Col A Col B Col C
1 A angry birds
1 A gaming
2 B nirvana
2 B rock
2 B band
I am sure this can be done with VBA but couldn't figure it out myself.

Answer 1

variant using Scripting.Dictionary
Sub ttt()
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim x&, cl As Range, rng As Range, k, s
Set rng = Range([C1], Cells(Rows.Count, "C").End(xlUp))
x = 1 'used as a key for dictionary and as row number for output
For Each cl In rng
For Each s In Split(cl.Value2, ",")
dic.Add x, Cells(cl.Row, "A").Value2 & "|" & _
Cells(cl.Row, "B").Value2 & "|" & LTrim(s)
x = x + 1
Next s, cl
For Each k In dic
Range(Cells(k, "A"), Cells(k, "C")).Value2 = Split(dic(k), "|")
Next k
End Sub
source:
result:

Answer 2

If you have a substantial amount of data, you willfind working with arrays beneficial.
Sub Macro2()
Dim i As Long, j As Long, rws As Long
Dim inp As Variant, outp As Variant
With Worksheets("sheet2")
inp = .Range(.Cells(1, "A"), .Cells(.Rows.Count, "C").End(xlUp)).Value2
For i = LBound(inp, 1) To UBound(inp, 1)
rws = rws + UBound(Split(inp(i, 3), ",")) + 1
Next i
ReDim outp(1 To rws, 1 To 3)
rws = 0
For i = LBound(inp, 1) To UBound(inp, 1)
For j = 0 To UBound(Split(inp(i, 3), ","))
rws = rws + 1
outp(rws, 1) = inp(i, 1)
outp(rws, 2) = inp(i, 2)
outp(rws, 3) = Trim(Split(inp(i, 3), ",")(j))
Next j
Next i
.Cells(1, "A").Resize(UBound(outp, 1), UBound(outp, 2)) = outp
End With
End Sub

Answer 3

This is not a polished solution, but I need to spend some time with the wife.
But still another way of thinking about it.
This code assumes that the sheet is called Sheet4 and the range that needs to be split is col C.
Dim lastrow As Integer
Dim i As Integer
Dim descriptions() As String
With Worksheets("Sheet4")
lastrow = .Range("C1").End(xlDown).Row
For i = lastrow To 2 Step -1
If InStr(1, .Range("C" & i).Value, ",") <> 0 Then
descriptions = Split(.Range("C" & i).Value, ",")
End If
For Each Item In descriptions
.Range("C" & i).Value = Item
.Rows(i).Copy
.Rows(i).Insert
Next Item
.Rows(i).EntireRow.Delete
Next i
End With

Answer 4

This will do what you want.
Option Explicit
Const ANALYSIS_ROW As String = "C"
Const DATA_START_ROW As Long = 1
Sub ReplicateData()
Dim iRow As Long
Dim lastrow As Long
Dim ws As Worksheet
Dim iSplit() As String
Dim iIndex As Long
Dim iSize As Long
'Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook
.Worksheets("Sheet1").Copy After:=.Worksheets("Sheet1")
Set ws = ActiveSheet
End With
With ws
lastrow = .Cells(.Rows.Count, ANALYSIS_ROW).End(xlUp).Row
End With
For iRow = lastrow To DATA_START_ROW Step -1
iSplit = Split(ws.Cells(iRow, ANALYSIS_ROW).Value2, ",")
iSize = UBound(iSplit) - LBound(iSplit) + 1
If iSize = 1 Then GoTo Continue
ws.Rows(iRow).Copy
ws.Rows(iRow).Resize(iSize - 1).Insert
For iIndex = LBound(iSplit) To UBound(iSplit)
ws.Cells(iRow, ANALYSIS_ROW).Offset(iIndex).Value2 = iSplit(iIndex)
Next iIndex
Continue:
Next iRow
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
End Sub