.
Here is one method :
Option Explicit
Sub cpySummary()
Dim i As Long
Dim j As Long
Dim LR As Long
Application.ScreenUpdating = False
For i = 1 To ThisWorkbook.Sheets.Count
If Sheets(i).Name <> ("Summary Sheet") Then
Sheets(i).Range("$A$1:$A$100").AutoFilter Field:=1, Criteria1:=RGB(216, 216, 216), Operator:=xlFilterCellColor
Sheets(i).Range("$A$1:$A$100").AutoFilter Field:=1, Criteria1:=RGB(255, 255, 204), Operator:=xlFilterCellColor
End If
Next
Dim wsM As Worksheet
Set wsM = Sheets("Summary Sheet")
j = 1 ' Start copying to row 1 in target sheet
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To ThisWorkbook.Sheets.Count
If Sheets(i).Name <> ("Summary Sheet") Then
If Sheets(i).Range("A2").Value = "Budget Comparison" Then
Sheets(i).Range("A1").Copy Destination:=wsM.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Sheets(i).Range("A5:I5").Copy Destination:=wsM.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Sheets(i).UsedRange.Offset(1).Copy Destination:=wsM.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
wsM.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = " "
j = j + 1
End If
End If
Next i
For i = 1 To ThisWorkbook.Sheets.Count
On Error Resume Next
If Sheets(i).AutoFilterMode Then
Sheets(i).AutoFilterMode = False
End If
Next
wsM.Columns("A:M").EntireColumn.AutoFit
wsM.Range("A1").Select
Application.ScreenUpdating = True
End Sub
Sub delRows()
Dim wsM As Worksheet
Set wsM = Sheets("Summary Sheet")
wsM.Rows("2:1000").Delete
End Sub