提高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