时间戳

首页 > 解决方案 > 加快/改进此 VBA 脚本的建议？

excel - 加快/改进此 VBA 脚本的建议？

问题描述

有什么建议或技巧可以让这个运行更好吗？我已经在较小的数据集（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

谢谢！

标签： excelvba

解决方案

获得良好加速的标准方法是在一条语句中将所有内容读入一个大 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

推荐阅读