如何加快这个VBA代码

Question

在此代码中查看包含来自不同系统的类似数据的2个工作表。第1列包含一个唯一的工作人员编号，因此可以匹配该人员，然后在工作表之间存在NiNo ws1.cell(,17) and ws2.cell(,24)的差异，然后将该人员的某些值复制到第3张工作表。

然而，有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