Улучшение производительности кода VBA о разделении строк

Question

Мне нужно сделать следующее:

У меня есть таблица, в которой 13-й столбец содержит такие строки, как

acbd,ef,xyz
qwe,rtyu,tqyuiop

И что я хочу создать новые строки для того, чтобы отделить эти значения:

acbd
ef
xyz
qwe
rtyu
tqyuiop

То есть теперь у меня будет 6 строк вместо 2, и вся остальная информация о ячейках останется прежней (то есть все другие значения строки будут повторяться во всех новых строках).

Я попробовал следующее:

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

Этот код работает отлично, за исключением того, что для таблиц с 400 строками требуется 15 + -5 секунд.

Мне бы хотелось несколько советов о том, как улучшить производительность этого. Спасибо!

Answer 1

Попробуйте это.

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

До.

После.

Если у вас есть еще столбцы, сделайте это.

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

Answer 2

С данными в столбце L , попробуйте:

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

Примечание:

Нет зацикливания на ячейках.
Нет зацикливания на ячейках.
Этот процесс может быть выполнен только с помощью формул рабочего листа, VBA не требуется.

Answer 3

Это должно искать значения через запятую в столбце M и перезаписывать значения в столбце M значениями разделения (в основном то, что делал ваш код).

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

Answer 4

Если вы хотите немедленного повышения производительности без необходимости настройки какого-либо кода, просто добавьте события приложения в начале ...

With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End With

и обязательно включите их снова в концекод ...

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

Эти два простых утверждения обычно значительно ускоряют код.