Split comma to rows

[sn3574]

Hi All,
I have been trying a code from the forum but it was super slow for my task and did not work in case the comma was set without spaces.
I am attaching an example , but my real excel is pretty big with lots of column and rows, so trying to find a better and faster split to rows if you have one.
I am basically trying to split a comma that can be with or without space to rows on the same sheet.

[Artik]

Stuff written on my lap
Sub SplitToRows()
Dim vData As Variant
Dim vResult As Variant
Dim i As Long
Dim k As Long
Dim m As Long
Dim lCol As Long
Dim lRow As Long
Dim vTmp As Variant


vData = Worksheets("Sheet1").Cells(1).CurrentRegion.Value
lCol = UBound(vData, 2)

ReDim vResult(1 To lCol, 1 To 1)


For i = 1 To UBound(vData)
lRow = lRow + 1
ReDim Preserve vResult(1 To lCol, 1 To lRow)

vTmp = Split(vData(i, 3), ",")
m = UBound(vTmp)

For k = 0 To m
vResult(1, lRow) = Trim(vData(i, 1))
vResult(2, lRow) = Trim(vData(i, 2))
vResult(4, lRow) = Trim(vData(i, 4))
vResult(5, lRow) = Trim(vData(i, 5))
vResult(3, lRow) = Trim(vTmp(k))

If k < m Then
lRow = lRow + 1
ReDim Preserve vResult(1 To lCol, 1 To lRow)
End If
Next k

Next i


If lRow > 65536 Then
vResult = TransposeDim(vResult)
Worksheets("Sheet2").Cells(1).Resize(UBound(vResult) + 1, UBound(vResult, 2) + 1) = vResult
Else
vResult = Application.Transpose(vResult)
Worksheets("Sheet2").Cells(1).Resize(UBound(vResult), UBound(vResult, 2)) = vResult
End If
End Sub



Function TransposeDim(vData As Variant) As Variant

With CreateObject("New:{8BD21D20-EC42-11CE-9E0D-00AA006002F3}")
.Column = vData
TransposeDim = .List
End With

End Function
Artik

[paulked]

Sub SplitList()
Dim arr1, arr2, arr3(), arr4, lr As Long, i As Long, j As Long, k As Long, x As Long
Dim str As String
lr = Cells(Rows.Count, 1).End(xlUp).Row
arr1 = Range("A2:E" & lr)
x = 0
For i = 1 To UBound(arr1)
arr2 = Split(arr1(i, 3), ",")
For j = 0 To UBound(arr2)
For k = 1 To 5
If k = 3 Then
str = str & Trim(arr2(j)) & ","
Else
str = str & Trim(arr1(i, k)) & ","
End If
Next
ReDim Preserve arr3(x)
arr3(x) = Split(Left(str, Len(str) - 1), ",")
x = x + 1
str = ""
Next
Next
arr4 = Application.Transpose(arr3)
Range("G2:K" & x + 1).Value = Application.Transpose(arr4)
End Sub


I spent ages trying to get arr3 direct to the sheet but couldn't!

[paulked]

Nice one Artik :thumb

[Artik]

paulked, but almost twice as slow as yours. :(

BTW. Did you know that the Transpose worksheet function still has its limit to 65536 rows? Since 2013 version, it doesn't report an error above this limit, but it does something worse. Cuts the returned data according to the formula:
Before transpose v(1 To 65536 * 2 + 2)
After transpose v(1 To 2, 1 To 1)
:devil2:

Artik

[paulked]

Until today, I knew nothing of transpose other than it 'rotated' data. That 16bit limit is something else I've learnt, thank you for sharing. I guess it's time they updated it!

[p45cal]

Or a Power Query solution.
Adjust Table1 for your real data, right-click and refresh the table at G12.
I would expect it to be quite fast.
Note that:

the Customer and date headers both have a trailing space
the dates are just strings, not real Excel dates (if I knew whether these were US or UK style dates I could have converted them to real dates at the same time)
I've manually deleted most of that table so you can see it populate on refresh


Note also, that in Artik's and paulked's procedures, the receiving cells are likely to try and convert those strings which look like dates into real dates; in this case there's no ambiguity, the dates are all 1st Jan 2020, but depending on your locale, dates such as 6/5/2020 will be interpreted differently.

[sn3574]

Stuff written on my lap
Sub SplitToRows()
Dim vData As Variant
Dim vResult As Variant
Dim i As Long
Dim k As Long
Dim m As Long
Dim lCol As Long
Dim lRow As Long
Dim vTmp As Variant


vData = Worksheets("Sheet1").Cells(1).CurrentRegion.Value
lCol = UBound(vData, 2)

ReDim vResult(1 To lCol, 1 To 1)


For i = 1 To UBound(vData)
lRow = lRow + 1
ReDim Preserve vResult(1 To lCol, 1 To lRow)

vTmp = Split(vData(i, 3), ",")
m = UBound(vTmp)

For k = 0 To m
vResult(1, lRow) = Trim(vData(i, 1))
vResult(2, lRow) = Trim(vData(i, 2))
vResult(4, lRow) = Trim(vData(i, 4))
vResult(5, lRow) = Trim(vData(i, 5))
vResult(3, lRow) = Trim(vTmp(k))

If k < m Then
lRow = lRow + 1
ReDim Preserve vResult(1 To lCol, 1 To lRow)
End If
Next k

Next i


If lRow > 65536 Then
vResult = TransposeDim(vResult)
Worksheets("Sheet2").Cells(1).Resize(UBound(vResult) + 1, UBound(vResult, 2) + 1) = vResult
Else
vResult = Application.Transpose(vResult)
Worksheets("Sheet2").Cells(1).Resize(UBound(vResult), UBound(vResult, 2)) = vResult
End If
End Sub



Function TransposeDim(vData As Variant) As Variant

With CreateObject("New:{8BD21D20-EC42-11CE-9E0D-00AA006002F3}")
.Column = vData
TransposeDim = .List
End With

End Function
Artik

I really liked this one - and it is sort of doing what I need.
There are few things which I am trying to adjust to and unable to do so:
1. Copy that to a different workbook without the need to open the source workbook.
2. Copy specific columns - starting from column B , Row 2 and aboove - so no need to copy the header as this will be copied to a teamplate sheet which will be merged from 2 different workbook.

[paulked]

I really liked this one - and it is sort of doing what I need.

Mine and Artiks do exactly the same thing, what you asked for!

1. You have to open the source.
2. ?

[Artik]

New questions are unrelated to the topic of this thread. Create a new thread. If necessary, please refer to this thread in it. Determine where and how you want to paste the data, because of the current questions are not clear.

And please don't quote the entire post if it is not necessary. You are littering the forum.

Artik

[Artik]

1. You have to open the source.
I don't know what the author meant. Does the data processed with this macro want to attach to a closed workbook, or does the source data want to download from a closed workbook.
In either case, you don't actually need to open the workbook. At least not explicitly. (ADO)

Artik

[sn3574]

Mine and Artiks do exactly the same thing, what you asked for!

1. You have to open the source.
2. ?


Sorry about the following - what I meant is that Artiks is providing me the option to select specific column I need and not a range - but both scripts are great.

I am attaching my idea - hope it makes it more clear.

Thanks,
SN

[paulked]

So the first time you transfer the results start at row 2. Do subsequent transfers go to the next available row, or is the existing data cleared?

[sn3574]

So the first time you transfer the results start at row 2. Do subsequent transfers go to the next available row, or is the existing data cleared?
Basically, clear data in Target except header and copy data from source there.

[paulked]

Try the attached to see if it's what you want.

The Source and target workbooks must be in the same directory or it won't work!

[jolivanes]

Another couple possibilities to play with.
Works on the attachment from Post #1.

Sub Maybe_1()
Dim ii As Long, bb, x As Long, t
Dim a, aa, i As Long, b, jj As Long, k As Long, j As Long
t = Timer
For ii = 2 To Cells(Rows.Count, 3).End(xlUp).Row
bb = Split(Cells(ii, 3), ",")
x = x + Len(Cells(ii, 3)) - Len(Replace(Cells(ii, 3), ",", ""))
Next ii

a = Cells(2, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1, 5).Value


ReDim aa(1 To x + Cells(Rows.Count, 3).End(xlUp).Row - 1, 1 To 5)


For i = LBound(a) To UBound(a)
b = Split(a(i, 3), ",")
For jj = LBound(b) + 1 To UBound(b) + 1
k = k + 1
j = 1
aa(k, j) = a(i, j)
aa(k, j + 1) = a(i, j + 1)
aa(k, j + 2) = Trim(b(jj - 1))
aa(k, j + 3) = a(i, j + 3)
aa(k, j + 4) = a(i, j + 4)
Next jj
Next i

Cells(2, 7).Resize(UBound(aa, 1), 5).Value = aa
MsgBox "This macro took " & Format(Round(Timer - t, 2), "00:00:00.00") & " seconds to run."
End Sub

Sub Maybe_2()
Dim c As Range, x As Long, t
Application.ScreenUpdating = False
t = Timer
For Each c In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
x = Len(c.Offset(, 2)) - Len(Replace(c.Offset(, 2), ",", "")) + 1
With Cells(Rows.Count, 7).End(xlUp).Offset(1).Resize(x)
.Value = c.Value
.Offset(, 1).Value = c.Offset(, 1).Value
.Offset(, 2).Value = Application.Transpose(Split(c.Offset(, 2), ","))
.Offset(, 3).Value = c.Offset(, 3).Value
.Offset(, 4).Value = c.Offset(, 4).Value
End With
Next c
Application.ScreenUpdating = True
MsgBox "This macro took " & Format(Round(Timer - t, 2), "00:00:00.00") & " seconds to run."
End Sub