Question

是否有任何建议或技巧可以使运行效果更好？我已经在较小的数据集（100-1000行）上使用了它，并且效果很好。尝试在大约100,000行的数据集上运行它，导致运行时无响应，我不得不强制退出excel。

    Sub CombineSchARecords()

        Dim myRow As Long

    'Row data starts
        myRow = 2

        Application.ScreenUpdating = False

    'Loop until out of data
        Do Until Cells(myRow, "A") = ""

    'Check to see if next row is for same filing number
        If Cells(myRow, "A") = Cells(myRow + 1, "A") Then

    'Add data to correct column
        Cells(myRow, "B") = Cells(myRow, "B") & ", " & Cells(myRow + 1, "B") 'SchA-3
        Cells(myRow, "C") = Cells(myRow, "C") & ", " & Cells(myRow + 1, "C") 'Schedule
        Cells(myRow, "D") = Cells(myRow, "D") & " | " & Cells(myRow + 1, "D") 'Full Legal Name
        Cells(myRow, "E") = Cells(myRow, "E") & ", " & Cells(myRow + 1, "E") 'DE/FE/I
        Cells(myRow, "F") = Cells(myRow, "F") & ", " & Cells(myRow + 1, "F") 'Entity in Which
        Cells(myRow, "G") = Cells(myRow, "G") & ", " & Cells(myRow + 1, "G") 'Title or Status
        Cells(myRow, "H") = Cells(myRow, "H") & ", " & Cells(myRow + 1, "H") 'Status Aquired
        Cells(myRow, "I") = Cells(myRow, "I") & ", " & Cells(myRow + 1, "I") 'Ownership Code
        Cells(myRow, "J") = Cells(myRow, "J") & ", " & Cells(myRow + 1, "J") 'Control Person
        Cells(myRow, "K") = Cells(myRow, "K") & ", " & Cells(myRow + 1, "K") 'PR
        Cells(myRow, "L") = Cells(myRow, "L") & ", " & Cells(myRow + 1, "L") 'OwnerID

    'Then delete row
        Rows(myRow + 1).Delete
            Else
        myRow = myRow + 1 'Move down one row if no match

            End If

Loop

Application.ScreenUpdating = True

End Sub

谢谢！

Answer 1

获得良好加速的标准方法是在一条语句中将所有内容读取到一个大的VBA数组中，在VBA中处理该数组，然后在另一条语句中将结果放回电子表格中。触摸电子表格的两行代码，而不是一个循环中超过100,000个电子表格的读/写

就您的问题而言，这意味着：

Sub CombineSchARecords()
    Dim n As Long, i As Long, j As Long
    Dim numRecords As Long
    Dim Values As Variant, Processed As Variant

    n = Cells(Rows.Count, 1).End(xlUp).Row
    Values = Range(Cells(2, "A"), Cells(n, "K")).Value
    ReDim Processed(1 To n - 1, 1 To 11)

    'initialize first row of Processed
    For j = 1 To 11
        Processed(1, j) = Values(1, j)
    Next j
    numRecords = 1

    'main loop

    For i = 2 To n - 1
        If Values(i, 1) = Processed(numRecords, 1) Then
            For j = 2 To 11
                Processed(numRecords, j) = Processed(numRecords, j) & IIf(j = 4, " | ", ", ") & Values(i, j)
            Next j
        Else 'start processing a new record
            numRecords = numRecords + 1
            For j = 1 To 11
                Processed(numRecords, j) = Values(i, j)
            Next j
        End If
    Next i

    'redim Values and copy records over

    ReDim Values(1 To numRecords, 1 To 11)
    For i = 1 To numRecords
        For j = 1 To 11
            Values(i, j) = Processed(i, j)
        Next j
    Next i

    'finally:
    Range(Cells(2, "A"), Cells(n, "K")).ClearContents
    Range(Cells(2, "A"), Cells(numRecords + 1, "K")).Value = Values

End Sub

Answer 2

除了使用VBA数组定义变量外，您还可以使用下面的代码来加速脚本。

Application.Calculation = xlManual
'Your code between this
Application.Calculation = xlAutomatic

有关加快/改进此VBA脚本的建议？

2 个答案: