Cut paste entire row to new sheet

[micko1]

I have a workbook that keeps track of sub contractors and thier compliance to insurances etc. I have a column in sheet "Regional Contractors) that has an if/or formula =IF(OR(F8<=TODAY(),G8<=TODAY(),H8<=TODAY()),"NonCompliant","") This formula is in column "O" starting in row 7. I have a named this range and called it "NonCompliant". I am trying to write a macro that will check the named range and cut any row it finds that equals NonCompliant and then paste it to a new sheet called "NonCompliant" starting from A7. The macro needs to look for the next vacant row in WS "NonCompliant" each time the button is pressed to ensure entries are not over writen. This is a sample of the code I have started with. It finds the correct rows, cuts and paste them to the new sheet and then deletes the empty rows on the original. Problem is if another entry becomes noncompliant and it needs to be moved to the second sheet "NonCompliant" it does not paste to a blank row.
Sorry to rave on and thanks for any help in advance.

Private Sub CommandButton1_Click()
Dim Ccell As Range
Dim Ws As Worksheet
Dim RowCounter() As Long
Dim r As Long
ScreenUpdating = False
ReDim RowCounter(Sheets.Count)
Application.ScreenUpdating = False
For Each Ws In Worksheets
RowCounter(Ws.Index) = 7
For Each Ccell In Range("Noncompliant") 'Sheetname defined in Excel names
If Ws.Name = Ccell.Value Then
Ccell.EntireRow.Cut
ActiveSheet.Paste Destination:=Sheets(Ws.Name).Cells(RowCounter(Ws.Index), 1)
RowCounter(Ws.Index) = RowCounter(Ws.Index) + 1
End If
Next
Next

For r = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Cells(r, 1) = "" Then Rows(r).Delete
Next r
ScreenUpdating = True

End Sub