Add blank row only applying to active worksheet

[Jaye16]

Hi all,

I am very new to Excel but have been trying to Frankenstein together a macro to knock out a number of tasks.

The macro runs right now (it's not pretty) but one portion of the code is only running on whatever worksheet is active (or at least I'm assuming. It doesn't work if I'm not on the WS I want it to run on, but if I'm on that sheet, it does.)

Sub SetSheetProperties()
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        'Set all sheets to legal size
        ws.PageSetup.PaperSize = xlPaperLegal
 
        'For sheets titled "Order history", wrap text and shrink columns wider than 100 to 90
        If ws.Name = "Order history" Then
            Dim col As Range
            For Each col In ws.UsedRange.Columns
                If col.ColumnWidth > 100 Then
                    col.WrapText = True
                    col.ShrinkToFit = True
                    col.ColumnWidth = 90
                End If
            Next col
        End If
 
        'For sheets titled "Subscription info", bold specific cells and insert blank rows
        If ws.Name = "Subscription info" Then
            Dim findValue As String
            Dim foundCell As Range
 
            'Bold cells with specific text
            findValue = "Account Information"
            Set foundCell = ws.Cells.Find(findValue)
            Do Until foundCell Is Nothing
                foundCell.Font.Bold = True
                Set foundCell = ws.Cells.FindNext(foundCell)
                If foundCell.Address = ws.Cells.Find(findValue).Address Then Exit Do
            Loop
 
            findValue = "Payment Information"
            Set foundCell = ws.Cells.Find(findValue)
            Do Until foundCell Is Nothing
                foundCell.Font.Bold = True
                Set foundCell = ws.Cells.FindNext(foundCell)
                If foundCell.Address = ws.Cells.Find(findValue).Address Then Exit Do
            Loop
 
            findValue = "Address History"
            Set foundCell = ws.Cells.Find(findValue)
            Do Until foundCell Is Nothing
                foundCell.Font.Bold = True
                Set foundCell = ws.Cells.FindNext(foundCell)
                If foundCell.Address = ws.Cells.Find(findValue).Address Then Exit Do
            Loop
 
            'Insert blank rows above cells with specific text
            Dim r As Long
            Dim lastRow As Long
            lastRow = Range("A" & Rows.Count).End(xlUp).Row
 
            For r = lastRow To 1 Step -1
                If Cells(r, 1).Value = "Account Information" And Cells(r, 1).Row > 1 Then Rows(r).Insert
            Next r
            
            'Set the Subscription info sheet to short date
            ws.Cells.NumberFormat = "mm/dd/yyyy"
            
            'Delete rows that only have data in column E
            Dim i As Long
            lastRow = ws.Range("E" & Rows.Count).End(xlUp).Row
            
            For i = lastRow To 1 Step -1
                If ws.Range("E" & i).Value <> "" And ws.Range("A" & i).Value = "" And ws.Range("B" & i).Value = "" And ws.Range("C" & i).Value = "" And ws.Range("D" & i).Value = "" And ws.Range("F" & i).Value = "" Then
                    ws.Range("E" & i).EntireRow.Delete
                End If
            Next i
        End If
    Next ws
End Sub

The portion I'm having trouble with is toward the bottom----

            'Insert blank rows above cells with specific text
            Dim r As Long
            Dim lastRow As Long
            lastRow = Range("A" & Rows.Count).End(xlUp).Row
 
            For r = lastRow To 1 Step -1
                If Cells(r, 1).Value = "Account Information" And Cells(r, 1).Row > 1 Then Rows(r).Insert
            Next r

When I run this macro, everything runs where it is supposed to regardless of the active sheet---except for this bit. For this bit, it does not apply unless I am on the sheet I want it run on "Subscription info"

I'm also trying to get it so that Header&Footer display on all sheets. The header and footer already have data in them that I want to leave, I simply want it to display the header and footer whereas the native file does not unless I click the Header/Footer button.

Can anyone help me clean this up and find out why it won't run how I'd like?

Thank you!

 

[nemmi69]

Don't you just need

'Insert blank rows above cells with specific text
            Dim r As Long
            Dim lastRow As Long
            lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
 
            For r = lastRow To 1 Step -1
                If ws.Cells(r, 1).Value = "Account Information" And ws.Cells(r, 1).Row > 1 Then ws.Rows(r).Insert
            Next r

 

[Jaye16]

Don't you just need

'Insert blank rows above cells with specific text
            Dim r As Long
            Dim lastRow As Long
            lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
 
            For r = lastRow To 1 Step -1
                If ws.Cells(r, 1).Value = "Account Information" And ws.Cells(r, 1).Row > 1 Then ws.Rows(r).Insert
            Next r

Yes! Thank you so much. That was simple!
Are you able to help with also trying to get it so that Header&Footer display on all sheets. The header and footer already have data in them that I want to leave, I simply want it to display the header and footer whereas the native file does not unless I click the Header/Footer button?

Thanks so much!