优化我的搜索和复制代码

Question

我有一个Excel项目，其中有几千行包含需要整理的字符串。 通常，每行中的一个单元应该具有六位数字123456，但是许多是123456/123456/234567等，其需要具有/删除然后被分离到各个行上。周围列中还有其他信息需要保留这六位数字。

我决定首先将行的副本复制适当的次数，然后删除多余的信息

下面这段代码涉及复制部分，它可以工作..但它真的很慢。有没有更快的方法来实现我想要做的事情？

感谢您的帮助。

克里斯

Sub Copy_extra_rows()

Application.ScreenUpdating = False

s = 2
Do Until s = Range("N20000").End(xlUp).Row

'checks for / in Mod list

    If InStr(1, Range("N" & s), "/") Then

'determines number of /

    x = Len(Range("N" & s)) - Len(Replace(Range("N" & s), "/", ""))

'loops x times and copies new row

        For a = 1 To x
        Range("J" & s & ":O" & s).Select
        Selection.Copy
        Range("J" & s + 1).Select
        Selection.Insert Shift:=xlDown
        s = s + 1
        Next a

    Else
    End If
s = s + 1
Loop

End Sub

Answer 1

我会以不同的方式解决这个问题，以优化流程并提高代码的整体效率。

首先，我会将整个列加载到一个数组中。这样，访问该数组的元素总是更快，而不是在循环中多次引用Cells()。使用内存中的对象要快得多，因为您的客户端不需要更新UI。通常，大O的数组是O（1），这意味着您可以立即访问存储在特定索引处的对象/数据。

我们考虑SSCCE。

然后代码（*注意：我在代码中添加了正确位置的注释，希望这有助于您了解正在发生的事情）

Sub Main()

    Dim columnArray As Variant

    ' create an array from Range starting at L2 to the last row filled with data
    columnArray = Range("N2:N" & Range("N" & Rows.Count).End(xlUp).Row)

    Dim c As New Collection
    ' add separate 6 digit numbers to the collection as separate items
    ' iterate the columnArray array and split the contents

    Dim element As Variant
    For Each element In columnArray
        If NeedSplitting(element) Then
            Dim splittedElements As Variant
            splittedElements = Split(element, "/")
            Dim splittedElement As Variant
            For Each splittedElement In splittedElements
                c.Add splittedElement
            Next
        Else
            c.Add element
        End If
    Next

    ' print the collection to column Q
    PrintToColumn c, "Q"

End Sub

Private Sub PrintToColumn(c As Collection, ByVal toColumn As String)
Application.ScreenUpdating = False
    ' clear the column before printing
    Columns(toColumn).ClearContents
    ' iterate collection and print each item on a new row in the specified column
    Dim element As Variant
    For Each element In c
        Range(toColumn & Range(toColumn & Rows.Count).End(xlUp).Row + 1) = element
    Next
Application.ScreenUpdating = True
End Sub

Private Function NeedSplitting(cell As Variant) As Boolean
    ' returns true if the cell needs splitting
    If UBound(Split(cell, "/")) > 0 Then
        NeedSplitting = True
    End If
End Function

运行代码后，所有数字都应显示为Q列中的单独元素

注意：为什么要使用Collection？

VBA中的

Collection是动态的。这意味着您不必知道集合的大小就可以使用它 - 与数组不同。 您可以多次重新调暗阵列以增加其大小，但这被认为是一种不好的做法。您可以使用简单的Collection.Add方法将几乎多个项添加到集合中，并且您不必担心手动增加大小 - 这些都是自动完成的。在这种情况下，处理发生在内存中，因此它应该更快，然后替换循环内的单元格内容。

Answer 2

试试这个：

Dim s As Integer
Dim splitted_array() As String
s = 2 'Assuming data starts at row 2
Do Until Range("N" & s).Value = vbNullString Or s >= Rows.Count
    'Split the array
    splitted_array = Split(Range("N" & s).Value, "/")
    If UBound(splitted_array) > 0 Then
        'Set the first value on the first row
        Range("N" & s).Value = splitted_array(0)
        For i = 1 To UBound(splitted_array)
            'Add subsequent rows
            Rows(s + i).Insert xlDown
            Range("J" & s + i & ":O" & s + i).Value = Range("J" & s & ":O" & s).Value
            Range("N" & s + i).Value = splitted_array(i)
        Next
    End If
    s = s + 1 + UBound(splitted_array)
Loop

此代码转为：

进入这个：