VBA Code to Delete empty Rows after Loop has finished

[life_in_picture_format]

I'm pretty happy with myself for getting this far on this idea of mine. When we write an employee up its based on a 12 month rolling period. So in other words they have that on their record for 12 month from the date. No one
was keeping track and it was a mess so I made this tracker. As of recent I figured out the code to remove entries that had expired of the sheet and onto a sheet I titled "Archives"

Here is the code:

Private Sub Workbook_Open()

b = Worksheets("DPS Disciplinary Actions").Cells(Rows.Count, 3).End(xlUp).Row 'open workbook as trigger
    Dim answer As Integer
 
    answer = MsgBox("Excel is checking to see if there are any DPS Infractions that have expired. ", vbCritical + vbOKOnly, "One Moment Please...") 'msgbox1 to tell folks Excel is working
    'by clicking ok for the previous msgboxit triggers another allowing excel to finish the process
    answer = MsgBox("If Excel locates and moves these old records, you will be able to see them on the Sheet Titled ""Archives""", vbInformation + vbOKOnly, "Just so You Know...")




'loop to check expired entries and place them on the archives sheet

For i = 4 To b
    If Worksheets("DPS Disciplinary Actions").Cells(i, 4).Value = "EXPIRED" Then
 
    Worksheets("DPS Disciplinary Actions").Rows(i).Cut 'cut and paste to the Archives sheet
 
    Worksheets("Archives").Activate
 
    a = Worksheets("Archives").Cells(Rows.Count, 3).End(xlUp).Row

    Worksheets("Archives").Cells(a + 1, 1).Select
 
    ActiveSheet.Paste
 
 
    Worksheets("DPS Disciplinary Actions").Activate
 
    End If
  Next
 
   Application.CutCopyMode = False
 
   ThisWorkbook.Worksheets("DPS Disciplinary Actions").Cells(1, 1).Select
 
 
End Sub

So I went from this:

To this but I could not figure out how to add "Delete empty rows" to the code as the finishing touch. Anyone know what I need to add to get it to do that?

 

[gifariz]

How about this?

Private Sub Workbook_Open()

b = Worksheets("DPS Disciplinary Actions").Cells(Rows.Count, 3).End(xlUp).Row 'open workbook as trigger
Dim answer As Integer

answer = MsgBox("Excel is checking to see if there are any DPS Infractions that have expired. ", vbCritical + vbOKOnly, "One Moment Please...")
'msgbox1 to tell folks Excel is working
'by clicking ok for the previous msgboxit triggers another allowing excel to finish the process
answer = MsgBox("If Excel locates and moves these old records, you will be able to see them on the Sheet Titled ""Archives""", vbInformation + vbOKOnly, "Just so You Know...")

'loop to check expired entries and place them on the archives sheet
i = 4
Do While i <= b
    'If expired, then cut paste onto other sheet and then delete current row
    'Note that if current row is deleted, all rows move up and row index i remains same
    If Worksheets("DPS Disciplinary Actions").Cells(i, 4).Value = "EXPIRED" Then
        Worksheets("DPS Disciplinary Actions").Rows(i).Cut
        'cut and paste to the Archives sheet
        Worksheets("Archives").Activate
        a = Worksheets("Archives").Cells(Rows.Count, 3).End(xlUp).Row
        Worksheets("Archives").Cells(a + 1, 1).Select
        ActiveSheet.Paste
        Worksheets("DPS Disciplinary Actions").Activate
        Worksheets("DPS Disciplinary Actions").Rows(i).EntireRow.Delete
    Else
        'If not expired, check next row (increase i)
        i = i + 1
    End If
Loop
Application.CutCopyMode = False
ThisWorkbook.Worksheets("DPS Disciplinary Actions").Cells(1, 1).Select

End Sub

Note that we can use "quick-wrap selection as VBA code" button in this forum to make reading code easier.