Excel VBA - Comma Separated Cells to Rows - vba

Question

Please help me with some advice regarding the below excel. In the incipient form looks like this:
A B C
1 A1 ;100;200;300;400;500;
2 A2 ;716;721;428;1162;2183;433;434;1242;717;718;
3 A3 ;100;101;
And i want to reach this result:
A B C
1 A1 100
1 200
1 300
1 400
1 500
2 A2 716
2 721
2 428
2 1162
2 2183
2 433
2 434
2 1242
2 717
2 718
3 A3 100
3 101
I tried using this code, but it does not return the expected result.
Sub SliceNDice()
Dim objRegex As Object
Dim X
Dim Y
Dim lngRow As Long
Dim lngCnt As Long
Dim tempArr() As String
Dim strArr
Set objRegex = CreateObject("vbscript.regexp")
objRegex.Pattern = "^\s+(.+?)$"
'Define the range to be analysed
X = Range([a1], Cells(Rows.Count, "b").End(xlUp)).Value2
ReDim Y(1 To 2, 1 To 1000)
For lngRow = 1 To UBound(X, 1)
'Split each string by ";"
tempArr = Split(X(lngRow, 2), ";")
For Each strArr In tempArr
lngCnt = lngCnt + 1
'Add another 1000 records to resorted array every 1000 records
If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 2, 1 To lngCnt + 1000)
Y(1, lngCnt) = X(lngRow, 1)
Y(2, lngCnt) = objRegex.Replace(strArr, "$1")
Next
Next lngRow
'Dump the re-ordered range to columns C:D
[c1].Resize(lngCnt, 2).Value2 = Application.Transpose(Y)
End Sub
Thanks in advance!

Answer 1

Try this:
Option Explicit
Sub DoSomething()
Dim i As Integer, j As Integer, k As Integer
Dim srcwsh As Worksheet, dstwsh As Worksheet
Dim sTmp As String, sNumbers() As String
Set srcwsh = ThisWorkbook.Worksheets("Sheet1")
Set dstwsh = ThisWorkbook.Worksheets("Sheet2")
i = 1
j = 1
Do While srcwsh.Range("A" & i) <> ""
sTmp = srcwsh.Range("C" & i)
sNumbers = GetNumbers(sTmp)
For k = LBound(sNumbers()) To UBound(sNumbers())
dstwsh.Range("A" & j) = srcwsh.Range("A" & i)
dstwsh.Range("B" & j) = srcwsh.Range("B" & i)
dstwsh.Range("C" & j) = sNumbers(k)
j = j + 1
Next
i = i + 1
Loop
Set srcwsh = Nothing
Set dstwsh = Nothing
End Sub
Function GetNumbers(ByVal sNumbers As String) As String()
Dim sTmp As String
sTmp = sNumbers
'remove first ;
sTmp = Left(sTmp, Len(sTmp) - 1)
'remove last ;)
sTmp = Right(sTmp, Len(sTmp) - 1)
GetNumbers = Split(sTmp, ";")
End Function
Note: i'd suggest to add error handler. For further information, please see: Exception and Error Handling in Visual Basic

Answer 2

This code will work for you
Sub SplitAndCopy()
Dim sh As Worksheet
Set sh = ThisWorkbook.Worksheets("YourTargetSheet")
Dim i As Long, j As Long, k As Long
k = 2
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
For j = LBound(Split(Range("C" & i).Value, ";")) + 1 To UBound(Split(Range("C" & i).Value, ";")) - 1
sh.Range("A" & k).Value = Range("A" & i).Value
If j = LBound(Split(Range("C" & i).Value, ";")) + 1 Then
sh.Range("B" & k).Value = Range("B" & i).Value
End If
sh.Range("C" & k).Value = Split(Range("C" & i).Value, ";")(j)
k = k + 1
Next j
Next i
End Sub

Answer 3

I would rather go this way:
Private Type data
col1 As Integer
col2 As String
col3 As String
End Type
Sub SplitAndCopy()
Dim x%, y%, c%
Dim arrData() As data
Dim splitCol() As String
ReDim arrData(1 To Cells(1, 1).End(xlDown))
x = 1: y = 1: c = 1
Do Until Cells(x, 1) = ""
arrData(x).col1 = Cells(x, 1)
arrData(x).col2 = Cells(x, 2)
arrData(x).col3 = Cells(x, 3)
x = x + 1
Loop
[a:d].Clear
For x = 1 To UBound(arrData)
Cells(c, 2) = arrData(x).col2
splitCol = Split(Mid(arrData(x).col3, 2, Len(arrData(x).col3) - 2), ";")
' sort splitCol
For y = 0 To UBound(splitCol)
Cells(c, 1) = arrData(x).col1
Cells(c, 3) = splitCol(y)
c = c + 1
Next y
Next x
End Sub
I am not totally sure if you need your third column sorted, in case you can add a sorting function.