Inserting rows above a specified rows

问题:

I am wondering how to insert 3 extra rows above a specified row that has "order type" (as specified below).

This row occurs multiple times in the sheet. The below code works, except it inserts the rows below the specified row. Thanks

Sub try()
    Dim c As Range

    For Each c In Range("A1:A100")
        If c.Value Like "*Order Type*" Then
            c.Offset(3, 0).EntireRow.Insert
        End If
    Next c
End Sub

回答1:

If your problem is to add 3 extra rows above searched criteria, solving your problem should be easy:

In you code line:

c.Offset(3, 0).EntireRow.Insert

Your line says when order type is found he should go 3 rows below and insert extra row.

Should go like this:

c.EntireRow.Resize(3).Insert

My line says, when order type is found, add 3 extra rows above it.

Hope this is what you looking for.

Edited:

I've searched Internet and found something similar to your problem and changed it according to you needs. Hope this will work for you. Little explanation how it works: it searches all the way through A column and if "Order Type" was found it adds 3 rows above it. When macro goes to blank cell it stops. Try it and tell me if it works good for you.

Sub AddRows()

Dim lastValue As String, i As Long, r As Long
Do
    r = r + 1
    If r > 1 And Cells(r, 1).Value Like "*Order Type*" Then
        If Cells(r, 1).Value = "" Then Exit Do
        For i = 1 To 3
            Rows(r).Insert Shift:=xlUp
        Next
        r = r + 3

        Else
            If IsEmpty(Cells(r, 1)) = True Then
            Exit Do

            Else

            End If

    End If
    lastValue = Cells(r, 1).Value
Loop

End Sub

回答2:

This should go up three rows instead of down three:

c.Offset(-3, 0).EntireRow.Insert

Use caution with this because if there are not three rows above the current row it will throw an error. A safer way to do this is by inserting from the current row + 2 more and shifting everything down.

Rows(c.Row & ":" & c.Row + 2).EntireRow.Insert Shift:=xlDown

Edit: The reason it runs until excel freezes is due to the way your loop is constructed. The first time it finds a match it inserts rows and then continues on finds the same match again causing it to get stuck in an infinite loop.

You can try this and see if it does what you want, it worked for me.

Sub try()
    Dim i As Long
    Dim c As Range

    Do While i < ActiveSheet.UsedRange.Rows.Count
        i = i + 1
        Set c = Cells(i, 1)

        If c.Value Like "*Order Type*" Then
            Rows(c.Row & ":" & c.Row + 2).EntireRow.Insert Shift:=xlDown
            i = i + 3
        End If
        Debug.Print i
    Loop
End Sub