时间戳

首页 > 解决方案 > 有没有办法将此循环更改为数组/范围引用？

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

问题描述

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

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

我试图为 I=lbound 设置一个数组循环到 ubound 但我离让它工作还差得很远（代码一团糟）。下面是一段代码和我正在尝试优化的循环之一。稍后还有 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

标签： arraysexcelvbadictionary

解决方案

你是对的，切换到 Variant Array 方法将大大加快速度。

您编写代码，重构为使用 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 行的一些模型数据上运行。

推荐阅读