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

在列 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 2

如果您想立即提高性能而不必调整任何类型的代码，只需在开头添加应用程序事件...

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

并确保在代码末尾将其重新打开...

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

这两个简单的语句通常可以大大提高代码的速度。

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

尝试一下。

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

提高有关拆分字符串的VBA代码的性能

4 个答案: