Sub Transfert()
Dim r As Range, c As Range
ChDir ThisWorkbook.Path 'chemin à adapter
Set r = Range("D3", Range("D" & Rows.Count).End(xlUp))
If r.Row < 3 Then Exit Sub
On Error Resume Next
Application.Dialogs(xlDialogOpen).Show
On Error GoTo 0
If ActiveWorkbook.Name = ThisWorkbook.Name Then Exit Sub
Application.ScreenUpdating = False
For Each r In r
If r <> "" Then
Set c = Cells.Find(r, , xlValues, xlWhole)
If Not c Is Nothing Then
c(1, 4).Resize(12) = Application.Transpose(r(1, 2).Resize(, 12))
End If
End If
Next
End Sub