60 USD Need to insert rows based on conditions up to a certain date. Re-run For Loop? Help

[treschouette]

Hello All,

I have the code below that uses a For Next loop to insert rows given specific conditions working from the last row up. However, I really need to insert as many rows every 30 days as necessary in the same manner up to a certain date or condition - that is, I do need to skip up through the rows but in order to make all the insertions that are necessary, I would need to have the For Next loop run more than once or something of that nature.

Essentially, rather than inserting one row per save given the conditions, as the code does now using a for loop, I need to insert all perfect point rows withing valid date conditions (as if the For loop were repeating its row scan until conditions stop it from repeating).

I have looked high and low to this point for a solution and keep either confusing or crashing the macro. Please help me see the error of my ways? Will reply to any questions. Thank you...

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
On Error GoTo errHnd
Application.EnableEvents = False
Dim lastrow, chkRw As Integer
'Determine last row with data in Column B
 lastrow = Range("B" & Rows.Count).End(xlUp).Row
'Loop from bottom of list to Row 2 in reverse order
   For chkRw = lastrow To 2 Step -1
'Compare the current cell to the one below it
'If conditions met, insert a perfect point row below the current Row
     If Range("B" & chkRw) <= Date - 30 _
     And Range("M" & chkRw) < 4 _
     And Range("N" & chkRw) = 0 _
     And Range("B" & chkRw) <> Range("B" & chkRw + 2) - 60 _
     Then
        Range("B" & chkRw).EntireRow.Copy
        Range("B" & chkRw + 1).EntireRow.Insert Shift:=xlDown
     'Put PerfectPoint value in column C
    Range("C" & chkRw + 1) = "00"
        'Put REC value in column N
    Range("N" & chkRw) = 1
    'Put date in Column B of inserted Row
      Cells(chkRw + 1, 2) = Cells(chkRw, 2) + 30
     ElseIf Range("B" & chkRw) <= Date - 30 _
     And Range("M" & chkRw) < 4 _
     And Range("N" & chkRw) = 0 _
     And Range("B" & chkRw + 1) = "" _
     And Range("B" & chkRw) <> Range("B" & chkRw + 2) - 60 _
     Then
        Range("B" & chkRw).EntireRow.Copy
        Range("B" & chkRw + 1).EntireRow.Insert Shift:=xlDown
        'Put PerfectPoint value in column C
    Range("C" & chkRw + 1) = "00"
        'Put REC value in column N
    Range("N" & chkRw) = 1
    'Put date in Column B of inserted Row
      Cells(chkRw + 1, 2) = Cells(chkRw, 2) + 30
    If Cells(chkRw, 3) = "16" Then
    Range("B" & chkRw + 1).EntireRow.Delete
        End If
            End If
         Next
        'Sort by Date
   Range("A1").CurrentRegion.Sort _
      Key1:=Range("B1"), Order1:=xlAscending, _
      Header:=xlYes
'Decrement the counter and do it again
Range("j3:M3").AutoFill Destination:=Range("j3:M" & Range("A" & Rows.Count).End(xlUp).Row)
errHnd:
'Re-enable event
Application.EnableEvents = True
End Sub

Paypal to Ozgrid Unique Transaction ID # 49P9309681906281V