Excel VBA

Copy On Criteria

Sub GetModsLists()
    Dim LastRow     As Long
    Dim CurSht      As Long
    Dim CurRow      As Long
    Dim PasRow      As Long
    Dim NewBook     As String
    
    Workbooks.Add
    ActiveWorkbook.SaveAs Filename:="DaFileName_Acc_" & Application.Text(Now(), "YYYY-MM-DD"), _
            FileFormat:=xlNormal
    NewBook = ActiveWorkbook.Name
    PasRow = 2
    
    ThisWorkbook.Activate
    Range("A4:D4").Select
    Selection.Copy
    Workbooks(NewBook).Activate
    Range("A1").Select
    ActiveSheet.Paste
    ActiveSheet.Cells(2, 2).Select
    ActiveWindow.FreezePanes = True
    ThisWorkbook.Activate
    For CurSht = 1 To Worksheets.Count
        Sheets(CurSht).Select
        LastRow = Range("A99000").End(xlUp).Row    'LAST ROW
        For CurRow = 5 To LastRow
            If Cells(CurRow, 1).Interior.Color <> 16777215 Then	'if its anything except no color
                Range(Cells(CurRow, 1), Cells(CurRow, 4)).Select
                Selection.Copy
                Debug.Print CurSht		'Went so fast I needed feedback
                Workbooks(NewBook).Activate
                PasRow = Range("A99000").End(xlUp).Row + 1
                Cells(PasRow, 1).Select
                ActiveSheet.Paste
                ThisWorkbook.Activate
                Sheets(CurSht).Select
            End If
        Next CurRow
    Next CurSht
    MsgBox "Done"
End Sub