提高VBA字符串比較的性能

Question

我想知道是否可以使用另一種技術來加速此代碼。 該代碼不會花費太長時間，但是看到通常需要多快才能操作某件東西，我很好奇是否可以提高它的速度。 該代碼僅用於檢查模板表中的每一列，以查看該值是否匹配，如果不匹配，則創建一個報告，以顯示有關零件以及不正確/正確值的信息。

Option Explicit

'Check values of table against template table
Sub checkTemplate(shnam1 As Worksheet, shnam2 As Worksheet, shnam3 As Worksheet)

    'Initalizes integers that will be used
    Dim rwIndex As Long             '"Item Attributes" row index
    Dim colIndex As Long            '"Item Attributes" column index
    Dim rowEnd As Long              'Last row in "Item Attributes"
    Dim colEnd As Long              'Last column in "Item Attributes"
    Dim tempIndex As Integer        

    Dim resRow As Long              'Current row in "Report" to paste
    Dim resCol As Long              'Current column in "Report" to paste
    Dim temp1 As String
    Dim temp2 As String

    'Gets bounds for "Item Attributes" table
    rowEnd = shnam1.Cells(Application.Rows.Count, 1).End(xlUp).Row
    colEnd = shnam1.Cells(1, Application.Columns.Count).End(xlToLeft).Column

    'Report Heading
    shnam3.Cells(1, 1).Value = "Oracle Part Number"
    shnam3.Cells(1, 2).Value = "Description"
    shnam3.Cells(1, 3).Value = "Attribute Name"
    shnam3.Cells(1, 4).Value = "Incorrect Value"
    shnam3.Cells(1, 5).Value = "Correct Value"

    resRow = 2                  'Set row for Results

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    'From 2nd row to last row
    For rwIndex = 2 To rowEnd

        tempIndex = 3       'Template table index
        resCol = 1          'Set column for results

        temp1 = shnam1.Cells(rwIndex, 1)
        temp2 = shnam1.Cells(rwIndex, 2)

        'From 3rd column to last column
        For colIndex = 3 To colEnd

            'Compare selection in data to template table
            If (shnam1.Cells(rwIndex, colIndex).Value) <> (shnam2.Cells(tempIndex, 1).Value) Then

                shnam3.Cells(resRow, resCol) = temp1
                shnam3.Cells(resRow, resCol + 1) = temp2

                'Copy attribute name
                shnam2.Cells(tempIndex, 2).Copy shnam3.Cells(resRow, resCol + 2)

                'Copy incorrect attribute value
                shnam1.Cells(rwIndex, colIndex).Copy shnam3.Cells(resRow, resCol + 3)

                'Copy correct attribute value
                shnam2.Cells(tempIndex, 1).Copy shnam3.Cells(resRow, resCol + 4)

                resRow = resRow + 1                 'Move down a row in the "Report" table

            End If

            tempIndex = tempIndex + 1           'Increment through template table

        Next colIndex

    Next rwIndex

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

End Sub

Answer 1

看看是否可以更快地運行：

Sub checkTemplate(shnam1 As Worksheet, shnam2 As Worksheet, shnam3 As Worksheet)

    Dim lCalc As XlCalculation
    Dim arrResults(1 To 65000, 1 To 5) As Variant
    Dim arrTable() As Variant
    Dim varCriteria As Variant
    Dim rIndex As Long
    Dim cIndex As Long
    Dim ResultIndex As Long

    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    On Error GoTo CleanExit

    arrTable = shnam1.Range("A1").CurrentRegion.Value
    For rIndex = 2 To UBound(arrTable, 1)
        For cIndex = 3 To UBound(arrTable, 2)
            varCriteria = shnam2.Cells(cIndex, "A").Value
            If arrTable(rIndex, cIndex) <> varCriteria Then
                ResultIndex = ResultIndex + 1
                arrResults(ResultIndex, 1) = arrTable(rIndex, 1)
                arrResults(ResultIndex, 2) = arrTable(rIndex, 2)
                arrResults(ResultIndex, 3) = shnam2.Cells(cIndex, "B").Text
                arrResults(ResultIndex, 4) = arrTable(rIndex, cIndex)
                arrResults(ResultIndex, 5) = varCriteria
            End If
        Next cIndex
    Next rIndex

    If ResultIndex > 0 Then
        With shnam3.Range("A1:E1")
            .Value = Array("Oracle Part Number", "Description", "Attribute Name", "Incorrect Value", "Correct Value")
            .Font.Bold = True
        End With
        shnam3.Range("A2:E2").Resize(ResultIndex).Value = arrResults
        shnam3.Range("A1").CurrentRegion.Sort shnam3.Range("A1"), xlAscending, Header:=xlYes
        shnam3.Range("A:E").EntireColumn.AutoFit
    End If

CleanExit:
    With Application
        .Calculation = lCalc
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    If Err.Number <> 0 Then
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If

    Erase arrResults
    Erase arrTable

End Sub