copia la riga in base all'intestazione della colonna e al colore della riga

Ho una macro che copia l'intero foglio 2 sul foglio 1 in base alle intestazioni.

Ad esempio,

Foglio 2 ha più colonne e Foglio 1 avrà solo 5 o 6 colonne con intestazioni di Foglio2. Con lo script sottostante, il foglio 1 estrarrà la riga completa; in base alle intestazioni del Foglio 2 (Es: 10). Ora, ho bisogno di modificare un po 'lo script in cui estrarrà solo le righe evidenziate (in rosso) dal foglio 2 in base alle intestazioni (es: 2 righe). Per favore aiuto.

Sub Macro1 ()
Dim Rng come intervallo, c come intervallo
Dim sCell come gamma
Dim taglia quanto a lungo
Dim dest come gamma
Dim headerRng come intervallo
Dim lDestRow quanto a lungo
Dim i As Integer
Application.ScreenUpdating = False 'Rimuovi il commento dopo il test

Fogli ("Foglio di base").Seleziona
i = 0
Imposta Rng = Intervallo([D1], [D1].End(xlToRight))


Per ogni c In Rng


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

Se c.Offset(1, 0).Valore <> "" Allora
'c.End(xlDown).Offset(1, 0).Resize(rSize, 1) = Fogli("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells( xlCellTypeVisible).Valore
Imposta destinazione = c.End(xlDown).Offset(1, 0)
Se i = 0 Allora
lRigaDest = RigaDest
End If

If dest.Row < lDestRow allora
Imposta destinazione = Celle(lDestRow, dest.Column)
End If

Fogli("Roster").Intervallo(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copia
dest.Seleziona
ActiveSheet.Paste


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

Intervallo(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
Imposta destinazione = c.Offset(1, 0)

If dest.Row < lDestRow allora
Imposta destinazione = Celle(lDestRow, dest.Column)
End If

dest.Seleziona
ActiveSheet.Paste
End If

i = i + 1
Avanti
Application.ScreenUpdating = True

End Sub