如何加快此VBA代码的速度

Question

在这段代码中，我们将查看2个工作表，其中包含来自不同系统的相似数据。 第1列包含一个唯一的职员编号，因此该人可以匹配，然后在工作表之间ws1.cell(,17) and ws2.cell(,24)有所不同ws1.cell(,17) and ws2.cell(,24) ，然后复制该人的某些值到第三张纸。

然而，有18个不同的工作表都在考虑不同的条件，因此此代码将必须运行18次，并且需要一段时间。 任何想法，我如何可以加快它的速度，请

 Sub NINODifferences()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    Dim i As Long, j As Long, iCol As Long, iRow As Long


    Set ws1 = ActiveWorkbook.Sheets("SheetA")
    Set ws2 = ActiveWorkbook.Sheets("SheetB")
    Set ws3 = ActiveWorkbook.Sheets("NINO Differences")


    iRow = 2
    iCol = 1

        For i = 1 To ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
            For j = 1 To ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row

                If Trim(ws1.Cells(i, 1).Value2) = Trim(ws2.Cells(j, 1).Value2) Then

                    If Trim(ws1.Cells(i, 17).Value2) <> Trim(ws2.Cells(j, 24).Value2) Then

                        ws3.Cells(iRow, iCol).Value2 = ws1.Cells(i, 1).Value2
                        iCol = iCol + 1
                        ws3.Cells(iRow, iCol).Value2 = ws1.Cells(i, 2).Value2
                        iCol = iCol + 1
                        ws3.Cells(iRow, iCol).Value2 = ws1.Cells(i, 3).Value2
                        iCol = iCol + 1
                        ws3.Cells(iRow, iCol).Value2 = ws1.Cells(i, 17).Value2
                        iCol = iCol + 1
                        ws3.Cells(iRow, iCol).Value2 = ws2.Cells(j, 24).Value2

                        iCol = 1
                        iRow = iRow + 1


                    Else
                    End If


                Else
                End If

            Next j
       Next i

    Set ws1 = Nothing
    Set ws2 = Nothing
    Set ws3 = Nothing

    End Sub

Answer 1

尝试重写您的代码（这将是一项艰巨的任务），尝试执行以下操作：

• 读取相应的单元格并将其保存到一个数组（或多个数组用于多个范围）
• 进行所有计算和条件评估，直到获得包含结果的数组
• 将此数组写入工作表

---

Sub TestMe()

    Dim firstArr        As Variant
    Dim secondArr       As Variant
    Dim cnt             As Long

    firstArr = Application.Transpose(Range("A1:A20"))
    secondArr = Application.Transpose(Range("B1:B20"))

    'Read the corresponding cells and save them to an array
    'Here instead of reading I am generating them
    For cnt = LBound(firstArr) To UBound(firstArr)
        firstArr(cnt) = cnt
        secondArr(cnt) = cnt * 3
        Cells(cnt, 1) = firstArr(cnt)
        Cells(cnt, 2) = secondArr(cnt)
    Next cnt

    'Make all the calculations until you receive an array with the results
    For cnt = LBound(firstArr) To UBound(secondArr)
        firstArr(cnt) = firstArr(cnt) + secondArr(cnt)
    Next cnt

    'Write this array to the worksheet
    For cnt = LBound(firstArr) To UBound(secondArr)
        Cells(cnt, 3) = firstArr(cnt)
    Next cnt

End Sub

如果您能够做到的话，性能奖金将是显而易见的。 作为小的建议（不要使用）-不要使用此行，有些人认为这是个坏习惯：

Application.Calculation = xlCalculationManual

Answer 2

本着Vityata所谈论的精神（重写代码以使用数组），并且不确定要使用什么样的数据：

 Sub NINODifferences()

Dim ws1 As Variant, ws2 As Variant, ws3 As Variant
Dim i As Long, j As Long

ws1 = ActiveWorkbook.Sheets("SheetA").UsedRange
ws2 = ActiveWorkbook.Sheets("SheetB").UsedRange
ReDim ws3(4, 0)
    For i = 1 To UBound(ws1)
        For j = 1 To UBound(ws2)
            If Trim(ws1(i, 1)) = Trim(ws2(j, 1)) Then
                If Trim(ws1(i, 17)) <> Trim(ws2(j, 24)) Then
                    ReDim Preserve ws3(4, count)
                    ws3(0, count) = ws1(i, 1)
                    ws3(1, count) = ws1(i, 2)
                    ws3(2, count) = ws1(i, 3)
                    ws3(3, count) = ws1(i, 17)
                    ws3(4, count) = ws2(i, 24)
                    count = count + 1
                End If
            End If
        Next j
   Next i
Call PasteArray(transposeArray(ws3), ActiveWorkbook.Sheets("NINO Differences").[A1])
Set ws1 = Nothing
Set ws2 = Nothing

End Sub

Sub PasteArray(data As Variant, rng As Range)
    rng.Resize(UBound(data, 1) + 1, UBound(data, 2) + 1) = data
End Sub

Function transposeArray(data)
If IsEmpty(data) Then Exit Function
ReDim r(UBound(data, 2), UBound(data))
For i = LBound(r) To UBound(r)
    For j = LBound(r, 2) To UBound(r, 2)
        r(i, j) = data(j, i)
    Next j
Next i
transposeArray = r
End Function