copy row based on columns header and row color

Question

I have a macro which copy's the entire Sheet 2 to Sheet 1 based on the headers.

For an example,

Sheet 2 has multiple columns and Sheet 1 will have only 5 or 6 column with headers of Sheet2. With below script, Sheet 1 will pull the complete row; based on the headers of Sheet 2 (Ex: 10). Now, I need to modify the script a bit where it will pull only highlighted(in Red) Rows from Sheet 2 based on the headers(Ex: 2 rows). Please help.

Sub Macro1()
Dim Rng As Range, c As Range
Dim sCell As Range
Dim rSize As Long
Dim dest As Range
Dim headerRng As Range
Dim lDestRow As Long
Dim i As Integer
Application.ScreenUpdating = False 'Uncomment after testing

Sheets("Base Sheet").Select
i = 0
Set Rng = Range([D1], [D1].End(xlToRight))

For Each c In Rng

Set sCell = Sheets("Roster").Range("1:1").Find(what:=c.Value, LookIn:=xlValues, lookat:=xlWhole)
rSize = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count

If c.Offset(1, 0).Value <> "" Then
'c.End(xlDown).Offset(1, 0).Resize(rSize, 1) = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
Set dest = c.End(xlDown).Offset(1, 0)
If i = 0 Then
lDestRow = dest.Row
End If

If dest.Row < lDestRow Then
Set dest = Cells(lDestRow, dest.Column)
End If

Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
dest.Select
ActiveSheet.Paste

Else
'c.Offset(1, 0).Resize(rSize, 1).Value = Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value

Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
Set dest = c.Offset(1, 0)

If dest.Row < lDestRow Then
Set dest = Cells(lDestRow, dest.Column)
End If

dest.Select
ActiveSheet.Paste
End If

i = i + 1
Next
Application.ScreenUpdating = True

End Sub

satırı sütun başlığına ve satır rengine göre kopyala