Insert blank row for each full row

Hello all!

I have another request for help.

Our accountant would like to insert a blank row in a spreadsheet for each row with data currently filled out. She want's the new row inserted under the row containing data.

Now I can write:

Code:

---

    Range( _
        "2:2,3:3,4:4,5:5,6:6,7:7,8:8,9:9,10:10,11:11,12:12,13:13,14:14,15:15,16:16,17:17,18:18").Select
    Range("A18").Activate
    Selection.Insert Shift:=xlDown

---

but that is ugly and not to mention tedious - so I need a For Each statement that will check to see if a row has data then

Code:

---

Range("x:x").Select
Selection.Insert Shift: = xlDown

---

where x = numer of the row with data on it...Should work,

Any suggestions?

Code:

---

For i = Cells(Rows.Count,"A").End(xlUp).Row To 1 STep -1
    If Application.CountA(Rows(i)) > 0 Then
        Rows(i+1).Insert
    End If
Next i

---

If column A does not contain data, the following may provide a solution

Code:

---


Sub Inserts()
    For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
    If Application.CountA(Rows(i)) > 0 Then
        If Application.WorksheetFunction.CountBlank(Rows(i)) <> 256 Then
            Rows(i + 1).Insert
        End If
    End If
    Next i
End Sub

---

Thanks for the help!!

I also wanted to set the Row height of the inserted Row to 50 pts. When I add RowHeight = 50 to the loop - for some reason only the first four Row's after my selected cell change...Why is that??

Any Idea's about how to insert the new Row at a new height??

Thanks again!

Code:

---

Sub Inserts()
    For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
    If Application.CountA(Rows(i)) > 0 Then
        If Application.WorksheetFunction.CountBlank(Rows(i)) <> 256 Then
            Rows(i + 1).Insert
            Selection.RowHeight = 50
        End If
    End If
    Next i
End Sub

---

Not sure what I'm doing wrong but I am still getting some inserted at 50 pts but most inserted @ the standard 17.25 pts or whatever the standard is.

Anyway I am dimensioning i as a Long - is that the problem??

Sorry. This should work

Code:

---

Option Explicit
Sub Inserts()
Dim i As Long
    For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
    If Application.CountA(Rows(i)) > 0 Then
        ActiveSheet.UsedRange.Rows.RowHeight = 50
        If Application.WorksheetFunction.CountBlank(Rows(i)) <> 256 Then
            Rows(i + 1).Insert
        End If
    End If
Next i
End Sub

---

Closer,

Now all the inserted Row's come in @ 50 pts - but so do the existing rows with data on them?

I only want to make the inserted Row's @ the new height

Thanks for the help!

This seems to work for me.

Code:

---

Sub Inserts()
    Dim i As Long
    For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
    If Application.CountA(Rows(i)) > 0 Then
        If Application.WorksheetFunction.CountBlank(Rows(i)) <> 256 Then
            Rows(i + 1).Insert
            Rows(i + 1).RowHeight = 50
        End If
    End If
Next i
End Sub

---

Thanks Norie,

I guess I should have tried to be more specific about which row I wanted to to manipulate - Rows(i +1).RowHeight = 50 works great for me as well. I'm still not sure what excel was doing when I just had RowHieght = 50 - but I'm glad you solved my problem,

Andy

I know I marked this as solved, but I have a quick question:

I want to reverse the process - Find all the newly inserted rows and delete them. Or maybe eaiser and more functional - find all empty Rows in a selection and delete those.

Any thoughts?

Hi Sam,
Try

Code:

---


Sub Deletes()
    Dim Cel As Range
    For Each Cel In Selection
        If Application.WorksheetFunction.CountBlank(Cel.EntireRow) = 256 Then
            Cel.EntireRow.Delete
        End If
    Next
End Sub

---

Malcolm, that will skip cells. It's best to iterate backwards when inserting/deleting...

Code:

---

Sub Deletes()
    Dim i As Long, Rng As Range
    Set Rng = Selection
    For i = Rng.Cells.Count To 1 Step -1
    If Application.WorksheetFunction.CountBlank(Rng(i).EntireRow) = 256 Then
        Rng(i).EntireRow.Delete
    End If
    Next
End Sub

---

Correct!:blush footinmout

Thanks Guy's!!
:thumb

Btw, I should have used a CountA instead of a CountBlank, especially in lieu of the next Office installment, will have more than 256 columns. :o:

Hi Zack,
Will the problem with the new version will be the 256, not the CountBlanks? Columns.Count instead of 256 would solve that.
Regards
Malcolm

Thanks a lot for the help and the info!

Everything works great - I just have a curious question to add:

Is there a faster way to accomplish the same result?

I ask because the spreadsheets our accountant will be appling this to are around 3,000 rows large. When I tested the code on a test sheet with only about 60 rows the code executed almost instantly - but when I used it on the real macoy it took 9-10 min. :bug:

I have a simalar problem with a price find code that I wrote awhile back, once a sheet passes the 1,000 row mark - it seems to take an extra long time :think:

Things might run quicker if you turn off screen updating.

Code:

---

Sub Inserts()
Dim i As Long
Application.ScreenUpdating = False
For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
    If Application.CountA(Rows(i)) > 0 Then
        If Application.WorksheetFunction.CountBlank(Rows(i)) <> 256 Then
            Rows(i + 1).Insert
            Rows(i + 1).RowHeight = 50
        End If
    End If
Next i
Application.ScreenUpdating = True
End Sub

---

Thanks Nori!

The offscreen updating is a bit faster - but I was wondering if I could aproach it like I would for setting the row height for the entire street. No matter how many Rows a sheet has it updates almost instantly... so could I select the content my self and just write an insert code for every other row?

Would that be faster??