VBA Delete Rows in sheet where formulas go to row 1000, then insert rows at bottom and copy formulas to new rows

39 Views Asked by At

I have a script that deletes rows based on a status cell in each row, then subsequently inserts new rows (same row count as those deleted) to the second to last row in the sheet. I am running into a problem when I try to copy the formulas down. As written, it copies everything (including inputs). I would like it to copy formulas only.

Background: Formulas go to row 1000 to keep the file size small. As soon as I delete a row, the formulas using those cells change from say A10:A1000 to A10:A999. Eventually the file will get too small, so I want to insert rows to get the formulas to always extend down to row 1000.

Code:

Sub Delete_range_ws2()

Dim i            As Long
Dim TexttoFind   As String
Dim ws2 As Worksheet
Set ws2 = Sheets("2. and 6. WD Input vs GL")

TexttoFind = "Ready to Delete" ' <-- Use a variable, this is easy to modify later

'Step 1: Find any row that has "Ready to Delete" and and delete the entir row.
For i = Range("CZ5000").End(xlUp).Row To 1 Step -1     'Find Last Row. NOTE, I put the range at 5x the 1000 row limit. I'm sure there is a better way, but I didn't have time to figure it out.
    If ws2.Range("CZ" & i) = TexttoFind Then            'Look in last row for "Ready to Delete"
        ws2.Rows(i).Delete                              'If found, delete row
    End If
    Range("A3").Select  'Bring user's view back to top left corner of sheet
Next

Dim lrow As Integer
Dim m As Integer
Dim n As Integer

'Step 2:  Now that we deleted rows, we need to add blank rows back into the sheet and copy formulas down
         'Why? Trying to make sure formulas continue to row 1000
With ws2
    lrow = Cells(Rows.Count, "A").End(xlUp).Row  'Now that rows have been deleted, find the new last row
    m = Cells(Rows.Count, "A").End(xlUp).Row - 1 'Find Second to last row
    n = 1000 - lrow       'Number of rows that were deleted
    
    If lrow = 1000 Then     'If true, then the above logic didn't delete any rows.
    Else
                            'If not True, then find the last row and insert the number of rows that were deleted
    ws2.Rows(lrow & ":" & m + n).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                            'Now that rows were inserted, we need to copy down
                            'formulas all the way to the limit of row 1000
                            'This is not perfect, it just goes back up the rows and finds a row to copy
                            'formulas down. THis WILL NOT Copy text inputs
    ws2.Rows(m - n).Copy
    ws2.Rows(m - n & ":1000").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone
           
    End If                  'Ends the IF Statement
    ws2.Range("A3").Select  'Bring user's view back to top left corner of sheet
End With                    'Ends the With Statement
    
End Sub
0

There are 0 best solutions below