Цикл по диапазону и вставка строки

Question

У меня есть большой набор данных, сгруппированный по заголовкам в столбце A. Я хочу просмотреть A10: A600 и каждый раз, когда найден заголовок "US 1", вставлять новую строку выше.Затем я хочу продолжить цикл до следующего экземпляра и т. Д.

Я попробовал приведенный ниже код, который находит значение и вставляет строки.Тем не менее, он продолжает вставлять бесконечное количество строк в первом экземпляре, а не переходить к следующему экземпляру «US 1»

Sub US_1()

Set rng = Range("A10:A600")

For Each cell In rng.Cells
 If cell.Value = "US 1" Then
 cell.EntireRow.Select
 Selection.Insert Shift:=xlDown

 End If

Next cell

End Sub

Я ожидаю, что он добавит строку над каждым экземпляром «US»1 ", однако добавляет бесконечные строки выше только первого экземпляра.

Answer 1

Проблема в том, что после прочтения A10 и вставки строки программа возобновляет поиск в A11.Но A11 находится там, где находится содержимое A10 (потому что оно было сдвинуто вниз из-за вставки).Попробуйте увеличить индексы самостоятельно и увеличить еще на один, если вставите строку.

Sub US_1()
    Set Rng = Range("A10:A600")
    For rowNr = Rng.Row To Rng.Row + Rng.Rows.Count - 1
        For colNr = Rng.Column To Rng.Column + Rng.Columns.Count - 1
            Set cell = Cells(rowNr, colNr)
            If cell.Value = "US 1" Then
                cell.EntireRow.Select
                Selection.Insert Shift:=xlDown
                rowNr = rowNr + 1
            End If
        Next colNr
    Next rowNr
End Sub

Answer 2

Sub US_1()
    Dim rng As Range
    Dim cell As Range
    Dim LAstRow As Long

    Set rng = Range("A10:A600")
    LAstRow = 0
    For Each cell In rng.Cells
        If cell.Value = "US 1" Then
             If cell.Row > LAstRow Then
                 cell.EntireRow.Insert Shift:=xlDown
                 LAstRow = cell.Row
             End If
       End If
    Next cell
End Sub

Answer 3

Option Explicit

Sub test()

    Dim i  As Long

    'Change name if needed
    With ThisWorkbook.Worksheets("Sheet1")

        For i = 600 To 10 Step -1
            If .Range("A" & i).Value = "US 1" Then
                .Rows(i).EntireRow.Insert
            End If
        Next i
    End With

End Sub

Answer 4

Это будет работать:

Sub US_1()

Dim i As Integer

For i = 10 To 600

 If Range("A" & i).Value = "US 1" Then
    Range("A" & i).EntireRow.Select
    Selection.Insert Shift:=xlDown
    i = i + 1
 End If

Next

End Sub

Вы вставляли строку в правильном направлении, но при вставке строки смещаются вниз, поэтому ваш цикл застрял в той же ячейке.