0

我想知道这段代码是否可以使用另一种技术加速。代码不会花费太长时间，但是看到某些东西的运行速度通常是想要的，我很好奇是否有什么我可以做的事情来提高它的速度。该代码仅用于根据模板表检查每一列以查看值是否匹配，如果不匹配，它会创建一个报告，显示有关部件的信息以及不正确/正确的值是什么。

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
4

1 回答 1

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
于 2013-08-16T19:37:20.143 回答