改进运行缓慢的Excel宏

Question

我有一个宏进行比较，然后这个宏根据信息是否匹配导出所有更改。 我有它，以便每列在新工作簿中获得自己的工作表。 我使用7个不同的计数整数，这需要很长时间，因为我输出超过6万行。

问题：是否有更快的方法来执行此代码？ 可以使用UDF吗？ 如果是这样的话？

Sub Export_Updates()

Dim ws As Worksheet
Dim wb2 As Workbook
Set wb = Application.Workbooks("Total Database Update_WORKING.xlsm")
Set ws = wb.Worksheets("Results")
Set wb2 = Application.Workbooks.Open("C:\Import Update.xlsx")
    i = 2
    ii = 2
    iii = 2
    iiii = 2
    iiiii = 2
    iiiiii = 2
    iiiiii = 2
    k = 2
    wb2.Activate
    Do While ws.Cells(k, 1) <> ""
        If ws.Cells(k, 4) = "No Match" Then
            wb2.Worksheets("AD UPDATE").Cells(i, 1) = ws.Cells(k, 1)
            wb2.Worksheets("AD UPDATE").Cells(i, 2) = ws.Cells(k, 2)
            i = i + 1
        End If
        If ws.Cells(k, 7) = "No Match" Then
            wb2.Worksheets("SENIOR UPDATE").Cells(ii, 1) = ws.Cells(k, 1)
            wb2.Worksheets("SENIOR UPDATE").Cells(ii, 2) = ws.Cells(k, 5)
            ii = ii + 1
        End If
        If ws.Cells(k, 10) = "No Match" Then
            wb2.Worksheets("ID UPDATE").Cells(iii, 1) = ws.Cells(k, 1)
            wb2.Worksheets("ID UPDATE").Cells(iii, 2) = ws.Cells(k, 8)
            iii = iii + 1
        End If
        If ws.Cells(k, 13) = "No Match" Then
            wb2.Worksheets("MINOR UPDATE").Cells(iiii, 1) = ws.Cells(k, 1)
            wb2.Worksheets("MINOR UPDATE").Cells(iiii, 2) = ws.Cells(k, 11)
        End If
        If ws.Cells(k, 16) = "No Match" Then
            wb2.Worksheets("MAJOR UPDATE").Cells(iiii, 1) = ws.Cells(k, 1)
            wb2.Worksheets("MAJOR UPDATE").Cells(iiii, 2) = ws.Cells(k, 14)
            iiii = iiii + 1
        End If
        If ws.Cells(k, 19) = "No Match" Then
            wb2.Worksheets("CAP UPDATE").Cells(iiiii, 1) = ws.Cells(k, 1)
            wb2.Worksheets("CAP UPDATE").Cells(iiiii, 2) = ws.Cells(k, 17)
            iiiii = iiiii + 1
        End If
        If ws.Cells(k, 22) = "No Match" Then
            wb2.Worksheets("PL UPDATE").Cells(iiiiii, 1) = ws.Cells(k, 1)
            wb2.Worksheets("PL UPDATE").Cells(iiiiii, 2) = ws.Cells(k, 20)
            iiiiii = iiiiii + 1
        End If
        k = k + 1
    Loop

    wb2.Save
    Sleep (1000)
    wb2.Close SaveChanges:=True
    wb.Activate
End Sub

欢迎任何建议。

Answer 1

我建议使用VBA数组进行处理。 在Excel环境和VBA环境之间进行是一个缓慢的过程，并且您为每行数据执行多次。 使用VBA阵列需要更多的编程，但速度差异可能很大（对于60K行的样本，速度快32倍）。

一般来说，最佳做法是

1. 使用二维数组，一步读取从Excel到VBA阵列的所有数据
2. 在VBA中处理数据，将结果存储在另一个VBA阵列中
3. 最后，将VBA阵列传回Excel

这是一个示例工作簿，显示了一些更具体的细节。

这是更快的VBA代码：

Sub Method2()
    Dim ws As Worksheet
    Dim wsOutput As Worksheet
    Dim rngRawData As Range
    Dim rngOutput As Range
    Dim rngToDelete As Range
    Dim vaRawData() As Variant
    Dim vaDiffs() As Variant

    t = Timer

    Set ws = ActiveSheet
    Set rngRawData = ws.Range("A1").CurrentRegion
    ' Transfers Excel data to a VBA array in one step.
    vaRawData = rngRawData

    'Loop through the VBA array, adding any No Match entries to the Diffs array
    ReDim vaDiffs(rngRawData.Rows.Count, 1 To 3)
    iDiffs = 0
    For i = LBound(vaRawData, 1) To UBound(vaRawData, 1)
    If vaRawData(i, 4) = "No Match" Then
        iDiffs = iDiffs + 1
        vaDiffs(iDiffs, 1) = vaRawData(i, 1) ' Capture the ID
        vaDiffs(iDiffs, 2) = vaRawData(i, 2) ' Capture the Source1 Value
        vaDiffs(iDiffs, 3) = vaRawData(i, 3) ' Capture the Source 2 value
    End If
    Next i

    'Transfer the Diffs array back to excel
    Set wsOutput = Worksheets("Diff2")
    wsOutput.Range("A1") = vaDiffs

    'Delete extra rows
    wsOutput.Cells(iDiffs + 2, 1) = "END"
    Set rngToDelete = wsOutput.Range(wsOutput.Cells(iDiffs + 2, 1), _
    wsOutput.Cells(rngRawData.Rows.Count + 3, 1))
    rngToDelete.EntireRow.Delete

    wsOutput.Activate
    MsgBox "It took " & Timer - t & " seconds."
End Sub

Answer 2

这是一个快速将工作表单元格的所有内容放入数组的示例。 这将使您比使用大量单元格引用更快地处理信息。 相信我，我有一个超过100K行的工作簿，我必须阅读其中的一些项目，我曾经迭代它来阅读它，现在我只是这样做，花了总时间把它从一两分钟到几秒钟。

Dim WS As Excel.Worksheet
Set WS = Excel.Workbooks(somebook).Worksheets(someworksheet)
Dim arr() as variant
arr = WS.UsedRange.Value

你有它。 最好的部分是参考保持不变。 那么你以前用过的东西

wb2.Worksheets("AD UPDATE").Cells(i, 1)

你现在可以使用了

arr(i, 1)

或者你选择命名数组的任何东西。 它使我的许多项目更加高效。