Private Sub Workbook_Activate()
Dim feuille, adr1$, adr2$, d As Object, wb As Workbook, f, tablo1, P As Range, tablo2, col%, lig&
feuille = Array("Feuil1", "Feuil2", "Feuil3", "Feuil4", "Feuil5") 'liste à adapter au besoin
adr1 = "A5:E15" 'adresse pour Classeur1
adr2 = "A5:E17" 'adresse pour Classeur2
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Set wb = Workbooks.Open(Me.Path & "\Classeur1.xlsm") 'ouverture du fichier source, à adapter au besoin
For Each f In feuille
tablo1 = wb.Sheets(f).Range(adr1) 'matrice, plus rapide
Set P = Me.Sheets(f).Range(adr2)
tablo2 = P.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For col = 3 To 5 Step 2 'colonnes à traiter
d.RemoveAll 'RAZ
ReDim resu(1 To UBound(tablo2), 1 To 1)
For lig = 1 To UBound(tablo1)
d(tablo1(lig, 1)) = tablo1(lig, col) 'mémorise la valeur
Next lig
For lig = 1 To UBound(tablo2)
resu(lig, 1) = d(tablo2(lig, 1))
Next lig
P.Columns(col) = resu 'restitution
Next col, f
wb.Close False
Application.EnableEvents = True 'réactive les évènements
End Sub