kopiraj vrstico na podlagi glave stolpca in barve vrstice

Imam makro, ki na podlagi glav kopira celoten list 2 v list 1.

na primer

List 2 ima več stolpcev, list 1 pa bo imel samo 5 ali 6 stolpcev z glavami Sheet2. S spodnjim skriptom bo List 1 potegnil celotno vrstico; na podlagi glave lista 2 (Primer: 10). Zdaj moram malo spremeniti skript, kjer bo potegnil samo označene (v rdeči barvi) vrstice iz lista 2 na podlagi glav (npr.: 2 vrstici). Prosim pomagajte.

Podmakro1()
Dim Rng kot razpon, c kot razpon
Dim Scell ​​As Range
Dim rSize As Long
Dim dest As Range
Dim headerRng kot obseg
Dim lDestRow As Long
Dim i kot celo število
Application.ScreenUpdating = False 'Prekliči komentar po testiranju

Listi("Osnovni list").Izberite
i = 0
Nastavite Rng = Obseg([D1], [D1].End(xlToRight))


Za vsak c In Rng


Nastavi 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

Če c.Offset(1, 0).Value <> "" Potem
'c.End(xlDown).Offset(1, 0).Resize(rSize, 1) = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells( xlCellTypeVisible).Value
Nastavi cilj = c.End(xlDown).Offset(1, 0)
Če je i = 0 Potem
lDestRow = ciljna vrstica
Konec Če

Če je dest.Row < lDestRow Potem
Nastavi cilj = Celice(lDestRow, Dest.Column)
Konec Če

Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
cilj.Izberi
ActiveSheet.Prilepi


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

Obseg(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
Nastavi cilj = c.Offset(1, 0)

Če je dest.Row < lDestRow Potem
Nastavi cilj = Celice(lDestRow, Dest.Column)
Konec Če

cilj.Izberi
ActiveSheet.Prilepi
Konec Če

i = i + 1
Naslednji
Application.ScreenUpdating = Res

End Sub