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

提高VBA字符串比较的性能

1 个答案: