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

[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)


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