Filter and copy to WorkSheet help

[LutonBarry]

Folks, I keep asking you all these questions and I'm learning an awful lot from you all so thanks very much.
The attached spreadsheets function is to rename the Resolver Group names in the rows beneath depending on the colour so 'Dtop-Red' or Dtop 'Ambr-Grn'. Then select and paste those groups into the respective worksheet tabs.

It works a treat if there are not Red rows or more than one. But if there is only one Red row the cell P2 is renamed after cell P1.

I cannot seem to think of a method around this, I've tried but without success.

I'm hoping /sure someone on this fine forum can come to my rescue and no doubt have a giggle at my code and simplify it even more.

Thanks in advance for all your help.

[p45cal]

Experiment with (no sorting prior to copying):

Sub blah()
ActiveSheet.Range("A1").AutoFilter Field:=16, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterCellColor
With ActiveSheet.AutoFilter
  .Range.Copy Sheets("Dtop-Red").Range("A1")
  With Intersect(ActiveSheet.UsedRange.Offset(1), .Range.SpecialCells(xlCellTypeVisible))
    Sheets("Dtop-Red").Range("P2").Resize(.Columns(1).Cells.Count) = "Dtop-Red"
    .EntireRow.Delete
  End With
  .ShowAllData
  .Range.Copy Sheets("Dtop-Ambr-Grn").Range("A1")
  Sheets("Dtop-Ambr-Grn").Range("P2").Resize(.Range.Rows.Count - 1) = "Dtop-Ambr-Grn"
  .Range.Offset(1).EntireRow.Delete
End With
End Sub

[LutonBarry]

P45Call. Thanks very much it works a treat I just had to insert a On error Resume Next command to cater for the event when no Red rows exist. What I like and admire so much about folks such as you on this forum is that you achieve in a quarter of the coding and simpler to what I have tried to achieve.

Also what I never appreciated was that you could have a With/End With statement inside and another With/End With statement.

So thanks very much. I will look at the methods and logic used in your code and learn from it, or at least try to.