有没有办法将此循环更改为数组/范围引用？

Question

我正在尝试使用字典将与唯一 ID 组合关联的总余额移动到另一张表。循环可能需要在数万行上运行，即使在 900 行上，该过程也需要大约 30 秒。

我的代码可以处理（多个）字典和循环，但速度很慢。我想知道是否有办法优化循环（可能通过使用数组？虽然我对它们非常缺乏经验）。

我尝试为 I=lbound 设置一个数组循环到 ubound，但我离让它工作还差得很远（代码一团糟）。下面是一个 sn-p 代码和我正在尝试优化的循环之一。稍后还有其他 4 个循环，但现在我只想优化一个。

'declare start/end rows
Dim StartRowPeriod As Long
    StartRowPeriod = 7
Dim LastRowPeriod As Long
    LastRowPeriod = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

'more dims for total bal
Dim HardCopyID As String
Dim Old_Balance As Double
Dim New_Balance As Double
Dim Updated_Balance As Double

Application.ScreenUpdating = False

'RUNNING THE DICTIONARY (ADDING THE TOTAL VALUES TO THE UNIQUE IDS)
For I = StartRowPeriod To LastRowPeriod
    HardCopyID = Cells(I, 11).Value
        If HardCopyID = "" Then
            Exit For
        ElseIf HardCopy_Dictionary.Exists(HardCopyID) Then
            Old_Balance = HardCopy_Dictionary(HardCopyID)
            New_Balance = Cells(I, 10).Value
            Updated_Balance = Old_Balance + New_Balance
            HardCopy_Dictionary(HardCopyID) = Updated_Balance
        Else
            HardCopy_Dictionary(HardCopyID) = Cells(I, 10).Value
        End If
Next I

Answer 1

你是对的，切换到变体数组方法将大大加快速度。

您的代码，重构为使用 Array，以及其他一些清理工作：

Sub Demo()
    ' declare all variables
    Dim i As Long
    Dim HardCopy_Dictionary As Dictionary ' early bound: set a reference to Microsoft Scripting Runtime
    'Dim HardCopy_Dictionary As Object ' late bound
    Dim ws As Worksheet
    Dim Dat As Variant

    'declare start/end rows
    Dim StartRowPeriod As Long
    Dim LastRowPeriod As Long

    'more dims for total bal
    Dim HardCopyID As String
    Dim Old_Balance As Double
    Dim New_Balance As Double
    Dim Updated_Balance As Double

    ' Application.ScreenUpdating = False 'not needed as there is no sheet interaction

    Set HardCopy_Dictionary = New Dictionary ' Early bound
    'Set HardCopy_Dictionary = CreateObject("Scripting.Dictionary")  ' Late bound

    Set ws = ActiveSheet

    StartRowPeriod = 7
    With ws
        LastRowPeriod = .Cells(.Rows.Count, 1).End(xlUp).Row

        ' Copy data to array
        Dat = .Range(.Cells(1, 1), .Cells(LastRowPeriod, 11)).Value
        'RUNNING THE DICTIONARY (ADDING THE TOTAL VALUES TO THE UNIQUE IDS)
        For i = StartRowPeriod To LastRowPeriod
            HardCopyID = Dat(i, 11) '.Cells(i, 11).Value
            If HardCopyID = vbNullString Then
                Exit For 'are you sure about this? Surley it should run to the end of the data?
            ElseIf HardCopy_Dictionary.Exists(HardCopyID) Then
                Old_Balance = HardCopy_Dictionary(HardCopyID)
                New_Balance = Dat(i, 10) '.Cells(i, 10).Value
                Updated_Balance = Old_Balance + New_Balance
                HardCopy_Dictionary(HardCopyID) = Updated_Balance
            Else
                HardCopy_Dictionary.Add HardCopyID, Dat(i, 10) '.Cells(i, 10).Value
            End If
        Next i
    End With
End Sub

这几乎可以立即在 100,000 行的一些模型数据上运行。

Answer 2

食谱

1. 使用完全限定范围参考，否则默认情况下您指的是活动工作表。

2. 通过 VBA 循环遍历范围总是很耗时，因此请使用数组。 建议参考您的工作表的代号（参见 VB 编辑器），例如。 Sheet1 和 将数据范围分配给 variant 2-dimensioned 1-based array，如下所示：

   Dim myArray     ' As Variant 
   MyArray = Sheet1.Range("A1:K" & Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp).Row)
   

3. 只需引用MyArray而不是Cells(...)或Sheet1.cells(...)或ThisWorkbook.Worksheets("Sheet1").Cells(...)这样写

   HardCopyID = myArray(I, 11).Value                      ' instead of HardCopyID = Cells(I, 11).Value
   New_Balance = myArray(I, 10).Value                     ' instead of New_Balance = Cells(I, 10).Value
   HardCopy_Dictionary(HardCopyID) = myArray(I, 10).Value ' instead of HardCopy_Dictionary(HardCopyID) = Cells(I, 10).Value
   

   （我假设您没有忘记在代码模块的声明头中使用Option Explicit 强制在此模块中显式声明 all 变量，例如Dim i As Long)

祝你好运:-)