具有动态范围/边界的循环答案

【问题标题】：For loop with dynamic range/borders具有动态范围/边界的循环
【发布时间】：2021-01-05 07:31:40
【问题描述】：

我想使用下面的代码循环遍历一系列单元格并检查“测试字”是否在其中一个单元格中。如果是，则插入新行并将下面的所有单元格向下移动一个单元格。现在的问题是，我使用j = Range("A:A").End(xlDown).Row 来确定for 循环的第二个计数器，并且这个计数器不会随着每次找到“Testword”时插入新行而改变。因此，必须检查值的单元格会超出边界并“错过”循环。

Sub Macro1()

    Dim i As Integer
    Dim j As Integer
        
    j = Range("A:A").End(xlDown).Row

    For i = 1 To j

        If Range("A" & i) = "Testword" Then
            Range("A" & i + 1).Insert
    
        End If
    
    Next i

End Sub

【问题讨论】：

标签： excel vba for-loop

【解决方案1】：

请尝试下一个方法。它会更快，在最后一次插入所有内容：

Sub Macro1()
    Dim i As Long, j As Long, rngIns As Range
        
    j = Range("A" & rows.count).End(xlUp).row 'it will work even with gaps in A:A column

    For i = 1 To j
        If Range("A" & i) = "Testword" Then
            If rngIns Is Nothing Then
                Set rngIns = Range("A" & i + 1)
            Else
                Set rngIns = Union(rngIns, Range("A" & i + 1))
            End If
        End If
    Next i
    If Not rngIns Is Nothing Then
        'solving cases of consecutive rows keeping the searched string:
        If InStr(rngIns.Address(0, 0), ":") > 0 Then _
                   Set rngIns = makeDiscontinuu(rngIns)
        rngIns.EntireRow.Insert
    End If
End Sub

Function makeDiscontinuu(rng As Range) As Range
   Dim a As Range, c As Range, strAddress As String
   For Each a In rng.Areas
        If a.cells.count = 1 Then
            strAddress = strAddress & a.Address(0, 0) & ","
        Else
            For Each c In a.cells
                strAddress = strAddress & c.Address(0, 0) & ","
            Next c
        End If
   Next a
   Set makeDiscontinuu = Range(left(strAddress, Len(strAddress) - 1))
End Function

【讨论】：

我不认为它会有那么大的不同......但我做了一个测试看看。约 35 行数据，其中 14 为“testrow”。 Forloop 向后用了 4.11 秒。 While 循环耗时 3.84 秒。这个答案 0.34 秒。写这么多代码看起来违反直觉。但是....将屏幕更新和计算设置为假/手动并运行 forloop 给了我 0.48 秒。
而使用 false/manual 的循环为 0.4 秒。实际上，添加或不添加任何行都需要相同的时间。我在工作表中打错了字，所以它写的是 testword 而不是 Testword。当我用错字运行代码时（显然）没有任何变化，但时间仍然是 0.4 秒。
@Andreas：如果要处理的范围确实很大并且出现次数也很大，那么差异可能会更大。如果连续行的情况非常罕见，甚至更快。对于这种情况，它可以更快，遍历数组并根据迭代行号构建单元格范围。但收益不大……
其实。我不敢苟同... 10072 行之前测试场景的复制粘贴。 While 循环耗时 11.2 秒。你的代码根本没有完成。它在 set makeDiskcontinuu = range.... （函数的最后一行）处崩溃。不确定字符串是否变长或发生了什么... 1004（已翻译）objec _global 中的方法范围失败。（或类似的东西）。但这需要的时间远远超过 11 秒。崩溃时可能约为 30... strAddress 崩溃时有 24 365 个字符，它看起来不错，但此时有些东西不起作用。也许范围有限制（？）
@Andreas：是的。地址字符串限制为 256 个字符。这就是为什么我更喜欢 Address(0, 0) 来保存一些字符... :) 你能在没有连续行出现的情况下进行一些速度测试吗？

【解决方案2】：

Sub Macro1()

    Dim i As Integer
    Dim j As Integer
        
    j = Range("A:A").End(xlDown).Row

    For i = j To 1 Step -1

        If Range("A" & i) = "Testword" Then
            Range("A" & i + 1).Insert
    
        End If
    
    Next i

End Sub

【讨论】：

【解决方案3】：

往回走……

Sub Macro1()

    Dim i As Integer
    Dim j As Integer
        
    j = Range("A:A").End(xlDown).Row

    For i = j To 1 step -1

        If Range("A" & i) = "Testword" Then
            Range("A" & i +1).Insert
    
        End If
    
    Next i

End Sub

或者使用while循环（效率较低）

Sub Macro1()

    Dim i As Integer

    i = 1
    while i < Range("A" & rows.count).End(xlUp).Row

        If Range("A" & i) = "Testword" Then
            Range("A" & i + 1).Insert
    
        End If
        i = i +1
    wend

End Sub

这将在每次迭代时更新循环。

【讨论】：

【解决方案4】：

@Andreas，请看这对代码。更复杂的代码仍然运行得更快，但是会发生一些奇怪的事情。我的意思是，如果您在保存后运行每个代码（以某种方式刷新应用程序/VBA/其他...），则运行时间最短。然后，在每对运行之后添加一些额外的秒数（至少是毫秒）。因此，请尝试下一段代码并确认它们在您的安装中的行为相同。

我在 8700 行范围内测试了这两个代码，搜索字符串出现了 1216 次：

Sub Macro1Simple()
    Dim i As Long, j As Long', dTime As Double
    
    j = Range("A" & rows.count).End(xlUp).row 'changed the way of calculation, for the case of inserted rows existence. 
    On Error Resume Next
     Range("A1:A" & j).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    
    j = Range("A" & rows.count).End(xlUp).row
    'dTime = MicroTimer 'to measure duration
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    For i = j To 1 Step -1

        If Range("A" & i) = "Testword" Then
            Range("A" & i + 1).Insert
        End If
    
    Next i
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    'MsgBox (MicroTimer - dTime) * 1000 & " [ms]"
    'Refresh
End Sub

复杂的版本：

Sub Macro1_Complicated()
    Dim i As Long, j As Long, rngIns As Range, arrRng() As Range', dTime As Double
        
    j = Range("A" & rows.count).End(xlUp).row 'it will work even with gaps in A:A column
    On Error Resume Next
     Range("A1:A" & j).SpecialCells(xlCellTypeBlanks).EntireRow.Delete: '  Stop
    On Error GoTo 0
    
    j = Range("A" & rows.count).End(xlUp).row
    'dTime = MicroTimer 'to measure duration
    
    For i = 1 To j
        If Range("A" & i) = "Testword" Then
            If rngIns Is Nothing Then
                Set rngIns = Range("A" & i + 1)
            Else
                Set rngIns = Union(rngIns, Range("A" & i + 1))
            End If
        End If
    Next i
    If Not rngIns Is Nothing Then
        If InStr(rngIns.Address(0, 0), ":") > 0 Then _
                   arrRng = makeDiscontNoLimit(rngIns)
        With Application
            .ScreenUpdating = False
            .Calculation = xlCalculationManual
        End With
        For i = 0 To UBound(arrRng)
            arrRng(i).EntireRow.Insert
        Next i
         With Application
            .ScreenUpdating = True
            .Calculation = xlCalculationAutomatic
        End With
    End If
    'MsgBox (MicroTimer - dTime) * 1000 & " [ms]"
    'Refresh
End Sub

Function makeDiscontNoLimit(rng As Range) As Variant
   Dim a As Range, c As Range, strAddress As String, strAddr() As Range, i As Long, k As Long
   Dim arNo As Long
   
   ReDim strAddr(100)
   For Each a In rng.Areas
        If a.cells.count = 1 Then
            strAddress = strAddress & a.Address(0, 0) & ","
            If Len(strAddress) >= 256 Then
                For i = Len(strAddress) - 1 To 1 Step -1
                    If Mid(strAddress, i, 1) = "," Then
                        Set strAddr(k) = Range(left(strAddress, i - 1)): k = k + 1
                        strAddress = Mid(strAddress, i + 1, Len(strAddress) - i): Exit For
                    End If
                Next i
            End If
        Else
            For Each c In a.cells
                strAddress = strAddress & c.Address(0, 0) & ","
                If Len(strAddress) >= 256 Then
                    For i = Len(strAddress) - 1 To 1 Step -1
                        If Mid(strAddress, i, 1) = "," Then
                            Set strAddr(k) = Range(left(strAddress, i - 1)): k = k + 1
                            strAddress = Mid(strAddress, i + 1, Len(strAddress) - i): Exit For
                        End If
                    Next i
                End If
            Next c
        End If
   Next a
   If Not strAddr(0) Is Nothing Then
        Set strAddr(k) = Range(left(strAddress, Len(strAddress) - 1))
        ReDim Preserve strAddr(k)
        makeDiscontNoLimit = strAddr: Exit Function
   Else
        Set strAddr(0) = Range(left(strAddress, Len(strAddress) - 1))
        ReDim Preserve strAddr(0)
        makeDiscontNoLimit = strAddr
   End If
End Function

我可以创建一个函数来处理将（有限地址）范围放入数组中的重复部分，但我只想看到它在大范围内工作。

所以，为了避免每次运行后持续时间增加，我尝试了Refresh，但没有任何结果。你能想出一种方法让 VBA 在所有运行中都以相同的效率运行吗？

我使用 API getFrequency 结合 getTickCount 来测量时间。但我认为这不是时间问题。我没有放置API函数和必要的Sub，让你使用你的测量方式......

【讨论】：