Argthtjtr

I need to do the following:

I have a table where the 13th column contains strings such as

acbd,ef,xyz

qwe,rtyu,tqyuiop

And what I want to create new rows in order to separate those values:

acbd

ef

xyz

qwe

rtyu

tqyuiop

Meaning I would have now 6 rows instead of 2, and all the other information on cells would remain the same (i.e. all the other values of the row would repeat themselves through all the new rows).

What I have tried is the following:

Sub test()



Dim coma As Integer

Dim finalString As String



Set sh = ActiveSheet

For Each rw In sh.Rows



* If find a coma, then copy the row, insert a new row, and paste in this new row*



If InStr(1, sh.Cells(rw.Row, 13).Value, ",") Then



Rows(rw.Row).Copy

Rows(rw.Row).insert shift:=xlShiftDown

Rows(rw.Row).PasteSpecial xlPasteValues



* Now it will look for the position of the comma and assign 

  to finalString what's before the comma, and assign to mod String

  what's after the comma *



coma = InStr(1, sh.Cells(rw.Row, 13).Value, ",")



finalString = Left(sh.Cells(rw.Row, 13).Value, coma - 1)

modString = Right(sh.Cells(rw.Row, 13).Value, Len(sh.Cells(rw.Row, 13).Value) - coma)



* Replace the values: *



sh.Cells(rw.Row, 13).Value = modString

sh.Cells(rw.Row - 1, 13).Value = finalString



End If



Next rw



MsgBox ("End")



End Sub

This code works perfectly well except that for tables with 400 rows it takes 15 +-5 seconds to be completed.

I would like some suggestions on how to improve the performance of this. Thank you!

Try this.

Sub test()

    Dim vDB, vR(), vS, s

    Dim i As Long, j As Integer, n As Long



    vDB = Range("a1").CurrentRegion



    For i = 1 To UBound(vDB, 1)

        vS = Split(vDB(i, 13), ",")

        For Each s In vS

            n = n + 1

            ReDim Preserve vR(1 To 13, 1 To n)

            For j = 1 To 12

                vR(j, n) = vDB(i, j)

            Next j

            vR(13, n) = s

        Next s

    Next i

    Range("a1").Resize(n, 13) = WorksheetFunction.Transpose(vR)



End Sub

Before.

After.

If you have more columns, do like this.

Sub test()

    Dim vDB, vR(), vS, s

    Dim i As Long, j As Integer, n As Long

    Dim c As Integer



    vDB = Range("a1").CurrentRegion

    c = UBound(vDB, 2)



    For i = 1 To UBound(vDB, 1)

        vS = Split(vDB(i, 13), ",")

        For Each s In vS

            n = n + 1

            ReDim Preserve vR(1 To c, 1 To n)

            For j = 1 To c

                vR(j, n) = vDB(i, j)

            Next j

            vR(13, n) = s

        Next s

    Next i

    Range("a1").Resize(n, c) = WorksheetFunction.Transpose(vR)



End Sub

With data in column L, give this a try:

Sub LongList()

    Dim wf As WorksheetFunction, arr, s As String



    Set wf = Application.WorksheetFunction



    s = wf.TextJoin(",", True, Range("L:L"))

    arr = Split(s, ",")

    Range("M1").Resize(UBound(arr) + 1, 1).Value = wf.Transpose(arr)

End Sub

Note:

No looping over cells.
No looping within cells.
This process can be accomplished with just worksheet formulas, VBA is not needed.

If you want an immediate boost in performance without having to adjust any kind of code just add Application events at the beginning...

With Application

    .DisplayAlerts = False

    .ScreenUpdating = False

End With

and be sure to turn them back on at the end of the code...

With Application

    .DisplayAlerts = True

    .ScreenUpdating = True

End With

These two simple statements usually speed up code considerably.

This should look for comma-delimited values in column M and overwrite the values in column M with the split values (basically what your code was doing).

Option Explicit



Sub splitValues()



    Dim sourceSheet As Worksheet

    Set sourceSheet = ActiveSheet



    With sourceSheet

        Dim lastRow As Long

        lastRow = .Cells(.Rows.Count, "M").End(xlUp).Row



        Dim inputValues() As Variant

        inputValues = .Range("M1:M" & lastRow).Value2



        Dim splitString() As String

        Dim rowIndex As Long

        Dim outputArray As Variant

        Dim outputRowIndex As Long

        outputRowIndex = 1



        For rowIndex = LBound(inputValues, 1) To UBound(inputValues, 1)

            splitString = VBA.Strings.Split(inputValues(rowIndex, 1), ",", -1, vbBinaryCompare)

            outputArray = Application.Transpose(splitString)

            .Cells(outputRowIndex, "M").Resize(UBound(outputArray, 1), UBound(outputArray, 2)).Value2 = outputArray

            outputRowIndex = outputRowIndex + UBound(outputArray, 1)

        Next rowIndex



    End With



End Sub