Problème intégration de plusieurs données

Bonjour,

J'ai un problème avec mon code, je voudrai copier les cellules que j'ai sélectionner dans un ordre précis à l'emplacement défini par mon critère sauf que cela me copier que la première cellule de ma sélection sur l'ensemble de la ligne(Il me copie que la cellule D12 sur toute la ligne). Pouvez-vous m'aider ?

Le code :

Sub TEST2()

'

' TEST2 Macro

'

'

Dim nbNonVide As Byte

Dim CopyRange As Range

Dim PasteRange As Range

nbNonVide = Application.WorksheetFunction.CountA(Worksheets("Feuil1").Range("D4"))

If nbNonVide = 0 Then

MsgBox "Merci de renseigner un emplacement"

ElseIf nbNonVide = 1 Then

If Worksheets("Feuil1").Range("D4") <> "" Then

Set CopyRange = ThisWorkbook.Worksheets("Feuil1").Range("D12, D14, D16, D18, D20, D22, D10, D8")

Set recherche = Worksheets("Feuil2").Range("B3:B10000").Find(What:=Worksheets("Feuil1").Range("D4").Value, LookAt:=xlWhole)

Set PasteRange = ThisWorkbook.Worksheets("Feuil2").Range("C" & recherche.Row & ":J" & recherche.Row)

PasteRange.Value2 = CopyRange.Value2

ElseIf Worksheets("Feuil1").Range("D4") <> "" Then

Worksheets("Feuil1").Range("D4").Select

End If

End If

End Sub