Блог

Я хочу использовать приведенный ниже код для перебора диапазона ячеек и проверки, находится ли «тестовое слово» в одной из этих ячеек. Если да, то вставляется новая строка, и все ячейки под ней перемещаются на одну ячейку вниз. Теперь проблема в том, что я использую j = Range("A:A").End(xlDown).Row для определения второго счетчика цикла for, и этот счетчик не меняется при перемещении путем вставки новых строк каждый раз, когда найдено «Тестовое слово». Таким образом, ячейки со значениями, которые необходимо проверить, выходят за границы и «пропускают» цикл.

 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" amp; i) = "Testword" Then
            Range("A" amp; i   1).Insert
    
        End If
    
    Next i

End Sub
 

Попробуйте следующий способ, пожалуйста. Это будет быстрее, если сразу вставить все в конец:

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

    For i = 1 To j
        If Range("A" amp; i) = "Testword" Then
            If rngIns Is Nothing Then
                Set rngIns = Range("A" amp; i   1)
            Else
                Set rngIns = Union(rngIns, Range("A" amp; 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 amp; a.Address(0, 0) amp; ","
        Else
            For Each c In a.cells
                strAddress = strAddress amp; c.Address(0, 0) amp; ","
            Next c
        End If
   Next a
   Set makeDiscontinuu = Range(left(strAddress, Len(strAddress) - 1))
End Function
 

 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" amp; i) = "Testword" Then
            Range("A" amp; i   1).Insert
    
        End If
    
    Next i

End Sub
 

Идите назад…

 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" amp; i) = "Testword" Then
            Range("A" amp; i  1).Insert
    
        End If
    
    Next i

End Sub
 

Или используйте цикл while (менее эффективный)

 Sub Macro1()

    Dim i As Integer

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

        If Range("A" amp; i) = "Testword" Then
            Range("A" amp; i   1).Insert
    
        End If
        i = i  1
    wend

End Sub
 

Это будет обновлять цикл на каждой итерации.

@Андреас, пожалуйста, посмотри на эту пару кодов. Более сложный код по-прежнему работает быстрее, но происходит что-то странное. Я имею в виду, что если вы запускаете каждый код после сохранения (каким-то образом обновите приложение / VBA / что угодно …), время выполнения будет минимальным. Затем, после каждой пары запусков, добавляется несколько дополнительных секунд (как минимум миллисекунд). Поэтому, пожалуйста, попробуйте следующие фрагменты кода и убедитесь, что они ведут себя так же при вашей установке.

Я протестировал оба кода в диапазоне из 8700 строк с 1216 искомыми вхождениями строк:

 Sub Macro1Simple()
    Dim i As Long, j As Long', dTime As Double
    
    j = Range("A" amp; rows.count).End(xlUp).row 'changed the way of calculation, for the case of inserted rows existence. 
    On Error Resume Next
     Range("A1:A" amp; j).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    
    j = Range("A" amp; 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" amp; i) = "Testword" Then
            Range("A" amp; i   1).Insert
        End If
    
    Next i
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    'MsgBox (MicroTimer - dTime) * 1000 amp; " [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" amp; rows.count).End(xlUp).row 'it will work even with gaps in A:A column
    On Error Resume Next
     Range("A1:A" amp; j).SpecialCells(xlCellTypeBlanks).EntireRow.Delete: '  Stop
    On Error GoTo 0
    
    j = Range("A" amp; rows.count).End(xlUp).row
    'dTime = MicroTimer 'to measure duration
    
    For i = 1 To j
        If Range("A" amp; i) = "Testword" Then
            If rngIns Is Nothing Then
                Set rngIns = Range("A" amp; i   1)
            Else
                Set rngIns = Union(rngIns, Range("A" amp; 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 amp; " [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 amp; a.Address(0, 0) amp; ","
            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 amp; c.Address(0, 0) amp; ","
                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 , чтобы вы могли использовать свой способ измерения…