卡车计算

Question

如何改进我的VBA代码以更快地运行？

我遇到的问题是，For/Next命令需要10小时来计算和打印所有数据。我无法转换计算，因为我需要为每个节点(check_nodes)计算的值。

我有一个表(“评级”)，它对所有check_node (38辆卡车)的每一个check_trucks (944个节点)执行计算(25)，所以这是25\times944\times38=896800数据点，然后被编译成38辆卡车中的每一辆卡车的不同的表格。我得到的结果和格式是正确的，我只需要以某种方式加快代码的速度。

最初，我打算单独运行所有38辆卡车的VBA，但随后决定修改代码以自动运行所有卡车。不幸的是，这大大增加了运行时间。

Sub Perform_Rating_Check()

Dim StartTime As Double
Dim SecondsElapsed As Double

'Remember time when macro starts
  StartTime = Timer

'------------------------
'DETERMINE NUMBER OF ROWS OF DATA FOR LOAD RATING SUMMARY
'------------------------

    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False

    Sheets("Output").Activate
    Row = Range("Start.Nodes").Row
    Column = Range("Start.Nodes").Column

    startRow = Range("Start.Nodes").Row
    nrows = Range("Num_Checks").Value

    ReDim check_nodes(1 To nrows)
    For q = 1 To nrows
        check_nodes(q) = Cells(startRow - 1 + q, Column)
    Next

'------------------------------
'CALCULATE & PRINT LOAD RATINGS
'------------------------------

    ReDim PR_summary(1 To nrows, 1 To 26)

    Sheets("Rating").Activate
    Truck_row = Range("Start.Truck").Row
    Truck_col = Range("Start.Truck").Column

    ntrucks = Range("Num.Trucks").Value

    ReDim check_trucks(1 To ntrucks)
    For k = 1 To ntrucks
        check_trucks(k) = Cells(Truck_row - 1 + k, Truck_col)
    Next

    For j = 1 To ntrucks
        TruckSheet = check_trucks(j)
        Range("Choose.Truck") = check_trucks(j)
        Sheets(TruckSheet).Activate
             For s = 1 To nrows
                Range("Check_Location") = check_nodes(s)
                PR_row = Range("A9").Row - 1
                PR_col = Range("A9").Column - 1
                Cells(PR_row + s, PR_col + 1) = check_nodes(s)
                Cells(PR_row + s, 2) = Range("RF_INV_Axial").Value
                Cells(PR_row + s, 3) = Range("RF_INV_Major").Value
                Cells(PR_row + s, 4) = Range("RF_INV_Minor").Value
                Cells(PR_row + s, 5) = Range("RF_OPR_Axial").Value
                Cells(PR_row + s, 6) = Range("RF_OPR_Major").Value
                Cells(PR_row + s, 7) = Range("RF_OPR_Minor").Value
                Cells(PR_row + s, 8) = Range("RF_INV_Axial_My").Value
                Cells(PR_row + s, 9) = Range("RF_INV_Major_My").Value
                Cells(PR_row + s, 10) = Range("RF_INV_Minor_My").Value
                Cells(PR_row + s, 11) = Range("RF_OPR_Axial_My").Value
                Cells(PR_row + s, 12) = Range("RF_OPR_Major_My").Value
                Cells(PR_row + s, 13) = Range("RF_OPR_Minor_My").Value
                Cells(PR_row + s, 14) = Range("RF_INV_Axial_Mz").Value
                Cells(PR_row + s, 15) = Range("RF_INV_Major_Mz").Value
                Cells(PR_row + s, 16) = Range("RF_INV_Minor_Mz").Value
                Cells(PR_row + s, 17) = Range("RF_OPR_Axial_Mz").Value
                Cells(PR_row + s, 18) = Range("RF_OPR_Major_Mz").Value
                Cells(PR_row + s, 19) = Range("RF_OPR_Minor_Mz").Value
                Cells(PR_row + s, 20) = Range("RF_INV_Shear_P").Value
                Cells(PR_row + s, 21) = Range("RF_INV_Shear_My").Value
                Cells(PR_row + s, 22) = Range("RF_INV_Shear_Mz").Value
                Cells(PR_row + s, 23) = Range("RF_OPR_Shear_P").Value
                Cells(PR_row + s, 24) = Range("RF_OPR_Shear_My").Value
                Cells(PR_row + s, 25) = Range("RF_OPR_Shear_Mz").Value
            Next s
    Next j

'Determine how many seconds code took to run
  SecondsElapsed = Round(Timer - StartTime, 2)

'Notify user in seconds
  MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True

End Sub

我喜欢当前打印数据的方式，但我只希望它运行得更快。上一次我运行代码时，大约花了10个小时才完成。

Answer 1

我不太清楚这里发生了什么，但这是一个非常明显的逐个单元数据传输，这是相当缓慢的：

   For s = 1 To nrows
        Range("Check_Location") = check_nodes(s)
        PR_row = Range("A9").Row - 1      '<< why not just =8?
        PR_col = Range("A9").Column - 1   '<<     and = 0 ?
        Cells(PR_row + s, PR_col + 1) = check_nodes(s)
        Cells(PR_row + s, 2) = Range("RF_INV_Axial").Value
        Cells(PR_row + s, 3) = Range("RF_INV_Major").Value
        'etc etc 
        Cells(PR_row + s, 25) = Range("RF_OPR_Shear_Mz").Value
    Next s

如果在一个调用中设置所有25个值，则速度会更快：

   For s = 1 To nrows
        Range("Check_Location") = check_nodes(s)
        PR_row = Range("A9").Row - 1      '<< why not just =8?
        PR_col = Range("A9").Column - 1   '<<     and = 0 ?
        Cells(PR_row + s, PR_col + 1).resize(1,25).value = _
            Array(check_nodes(s), Range("RF_INV_Axial").Value, _
                  Range("RF_INV_Major").Value,{etc etc} ,Range("RF_OPR_Shear_Mz").Value)
    Next s

同样，正如John所建议的，将计算切换到手动，并在准备好要创建的下一组值时在公式表上调用Calculate。

Answer 2

您缺少代码模块顶部的选项显式。把它加进去。从菜单Tools>Options中显示选项对话框。

在Options dialog>Editor tab>Code Settings group>Require变量声明中，确保它旁边有一个复选标记。

你的未来我会感谢你这么做的。这要求您声明任何变量Dim foo as Long，然后才能在代码foo = 10中的任何地方使用它们。这样你就可以省去太多的挫败感。

你在使用不合格的Range对象。这导致了两方面的问题。首先，什么是不合格的范围？Range("Foo")而不是specifiedSheet.Range("Foo")。通过没有完全限定表的范围，范围是使用任何意外发生的ActiveSheet来获得该范围。这是一个问题，因为您需要首先使用Worksheet.Activate法来激活工作表，然后希望/祈祷/希望在代码运行时不要激活另一个工作表。激活工作表是一种负担，并不是必需的。

这方面的一个例子是它对命名范围造成的模糊性。Range("Start.Nodes")的作用域是活动的工作表，还是工作簿的作用域？我从代码本身看不出来。我的重构将假设它们的作用域为工作表。

您正在使用Range对象的默认成员。这是什么？使用specifiedSheet.Range()或specifiedSheet.Cells(,)代替specifiedSheet.Range().Value2。在第一种情况下，您隐式地使用它来获取单元格的值，第二种是显式显示的。您可以在对象浏览器中看到这一点，通过在VBE中按F2来显示。确保显示隐藏成员并导航到Range类，然后导航到默认值。teal图标表示它是默认成员。

如果您好奇为什么使用Value2，请阅读查尔斯·威廉姆斯在-慢速文本及其避免文本与值与VALUE2 2上的文章。

您有注释块样式标头。

'------------------------
'DETERMINE NUMBER OF ROWS OF DATA FOR LOAD RATING SUMMARY
'------------------------

评论应该说明为什么有些事情会这样做。通过使用适当的描述性名称，可以看出什么是明显的。这适用于所有的名称，无论它们是为变量、函数、Sub等等。一个明确的名称，说明它是什么，或正在做什么，使您的代码自文档化。在变量中有一个这样的例子。Dim startRow as Long声明它是开始行。然后还有q、k、j、s、nrows等等，这根本无助于可读性。

您还可以创建一个特定的函数并返回它的名称。这可以让你把步骤分解成小模块。下面是一个例子。

Private Function GetCheckNodes(ByVal topLeftCell As Range, ByVal numberOfRows As Long) As Variant
    GetCheckNodes = Application.WorksheetFunction.Transpose(topLeftCell.Resize(numberOfRows, 1))
End Function

Application.WorksheetFunction.Transpose用于将数组从2D数组转到一维数组。在使用此函数的地方，可以为参数提供参数。

Dim checkNodes As Variant
checkNodes = GetCheckNodes(outputSheet.Range("Start.Nodes"), numberOfRows)

一定要将提供给这些功能的信息限制在实际需要知道的范围内，这样才能完成任务。这需要一些重构和检查代码是什么或应该做什么，但从长远来看，这可以帮助清理很多事情。

当您有跨多行或多列的连续范围时，不要单独选择每个行或列。想象一下台面上的一个袋子弹珠，然后一次一个捡起来。你就是这么做的。因为你知道开始行和结束行，你可以--可以--一次得到整个范围，然后把它存储在一个变量中。上面的重构示例说明了这一点。你本来有

ReDim check_nodes(1 To nrows)
For q = 1 To nrows
    check_nodes(q) = Cells(startRow - 1 + q, Column)
Next

重写为topLeftCell.Resize(numberOfRows, 1)。它使用Range.Resize性质来调整范围选择的大小，并在一个步骤中得到它。而不是拾取1，5,100或10,000个单元格，而是得到一个范围对象。快多了。

在变量名中使用下划线_。这是在对象通过使用实现语句实现接口时使用的约定。

这些都是在我使用https://github.com/rubberduck-vba/Rubberduck进行重构之后捕捉到的，我是其中的一个贡献成员：

您的子语句 for Sub Perform_Rating_Check()没有访问修饰符。正因为如此，它是隐式公开的。

对Sheets的调用隐式地引用了ActiveWorkbook。

考虑到上述所有因素，我提出了下面的代码。变量名是描述性的，并让您知道它们的用途。有些潜艇专门做一件事，而只有一件事。

因为我不确定你的命名范围，我以为它们在特定的单子上。如果这是错误的，并且它们被限定在工作簿上，那么ThisWorkbook.Range("foo")将使它们正常工作。

Option Explicit

Const lowerBoundColumnTransfer As Long = 1
Const upperBoundColumnTransfer As Long = 25

Public Sub PerformRatingCheck()
    Dim StartTime As Double
    StartTime = Timer

    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False

    Dim outputSheet As Worksheet
    Set outputSheet = ThisWorkbook.Sheets("Output") 'Can be referred to by its code name

    Dim numberOfRows As Long
    numberOfRows = outputSheet.Range("Num_Checks").Value2

    Dim checknodes As Variant
    checknodes = GetCheckNodes(outputSheet.Range("Start.Nodes"), numberOfRows)

    Dim ratingSheet As Worksheet
    Set ratingSheet = ThisWorkbook.Sheets("Rating") 'Can be referred to by its code name

    Dim numberOfTrucks As Long
    numberOfTrucks = ratingSheet.Range("Num.Trucks").Value2

    Dim namesOfTruckSToCheck As Variant
    namesOfTruckSToCheck = GetNamesOfTrucksToCheck(ratingSheet.Range("Start.Truck"), ratingSheet.Range("Num.Trucks").Value2)

    Dim truckName As Variant
    For Each truckName In namesOfTruckSToCheck
        PopulateTruckSheet ThisWorkbook.Sheets(truckName), checknodes
    Next

    Dim SecondsElapsed As Double
    SecondsElapsed = Round(Timer - StartTime, 2)
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
End Sub

Private Function GetCheckNodes(ByVal topLeftCell As Range, ByVal numberOfRows As Long) As Variant
    GetCheckNodes = Application.WorksheetFunction.Transpose(topLeftCell.Resize(numberOfRows, 1))
End Function

Private Function GetNamesOfTrucksToCheck(ByVal firstTruckCell As Range, ByVal numberOfTrucks As Long) As Variant
    GetNamesOfTrucksToCheck = firstTruckCell.Resize(numberOfTrucks, 1).Value2
End Function

Private Sub PopulateTruckSheet(ByVal truckSheet As Worksheet, ByVal checknodes As Variant)
    'Unable to definitively determine which sheet named range is on.
    'Assuming it's on scoped to each worksheet. If scoped to workbook
    'replace truckSheet with Thisworkbook
    truckSheet.Range("Choose.Truck").Value2 = truckSheet.Name

    Dim truckInfo As Variant
    truckInfo = GetTruckInformation(truckSheet, checknodes)

    Const PR_row As Long = 8
    Dim populationArea As Range
    Set populationArea = truckSheet.Cells(PR_row + 1, 1).Resize(UBound(truckInfo), UBound(truckInfo, 2))
    populationArea.Value2 = truckInfo
End Sub

Private Function GetTruckInformation(ByVal sourceSheet As Worksheet, ByVal checknodes As Variant) As Variant
    Dim tempArray As Variant
    ReDim tempArray(LBound(checknodes) To UBound(checknodes), lowerBoundColumnTransfer To upperBoundColumnTransfer)

    Dim counter As Long
    For counter = LBound(checknodes) To UBound(checknodes)
        Dim checkNode As String
        checkNode = checknodes(counter)
        sourceSheet.Range("Check_Location").Value2 = checkNode

        Dim truckInfoForRow As Variant
        truckInfoForRow = GetTruckInformationForRow(sourceSheet, checkNode)

        Dim columnTransfer As Long
        For columnTransfer = lowerBoundColumnTransfer To upperBoundColumnTransfer
            tempArray(counter, columnTransfer) = truckInfoForRow(columnTransfer)
        Next
    Next counter

    GetTruckInformation = tempArray
End Function

Private Function GetTruckInformationForRow(ByVal sourceSheet As Worksheet, ByVal checkNode As String) As Variant
    'If these are workbook scoped named ranges the parameter sourceSheet can be deleted
    Dim tempArray As Variant
    ReDim tempArray(lowerBoundColumnTransfer To upperBoundColumnTransfer)
    tempArray(1) = checkNode
    tempArray(2) = sourceSheet.Range("RF_INV_Axial").Value2
    tempArray(3) = sourceSheet.Range("RF_INV_Major").Value2
    tempArray(4) = sourceSheet.Range("RF_INV_Minor").Value2
    tempArray(5) = sourceSheet.Range("RF_OPR_Axial").Value2
    tempArray(6) = sourceSheet.Range("RF_OPR_Major").Value2
    tempArray(7) = sourceSheet.Range("RF_OPR_Minor").Value2
    tempArray(8) = sourceSheet.Range("RF_INV_Axial_My").Value2
    tempArray(9) = sourceSheet.Range("RF_INV_Major_My").Value2
    tempArray(10) = sourceSheet.Range("RF_INV_Minor_My").Value2
    tempArray(11) = sourceSheet.Range("RF_OPR_Axial_My").Value2
    tempArray(12) = sourceSheet.Range("RF_OPR_Major_My").Value2
    tempArray(13) = sourceSheet.Range("RF_OPR_Minor_My").Value2
    tempArray(14) = sourceSheet.Range("RF_INV_Axial_Mz").Value2
    tempArray(15) = sourceSheet.Range("RF_INV_Major_Mz").Value2
    tempArray(16) = sourceSheet.Range("RF_INV_Minor_Mz").Value2
    tempArray(17) = sourceSheet.Range("RF_OPR_Axial_Mz").Value2
    tempArray(18) = sourceSheet.Range("RF_OPR_Major_Mz").Value2
    tempArray(19) = sourceSheet.Range("RF_OPR_Minor_Mz").Value2
    tempArray(20) = sourceSheet.Range("RF_INV_Shear_P").Value2
    tempArray(21) = sourceSheet.Range("RF_INV_Shear_My").Value2
    tempArray(22) = sourceSheet.Range("RF_INV_Shear_Mz").Value2
    tempArray(23) = sourceSheet.Range("RF_OPR_Shear_P").Value2
    tempArray(24) = sourceSheet.Range("RF_OPR_Shear_My").Value2
    tempArray(25) = sourceSheet.Range("RF_OPR_Shear_Mz").Value2

    GetTruckInformationForRow = tempArray
End Function

也许还有更多的事情可以做，我已经对你的命名范围进行了太多的推测。