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 に答える