Sub copier2()
'Nécessite l'insertion en feuille "code" d'une colonne D contenant les codes couleur (Noir=1;Rouge=3;Vert=43
'et pour Foyer Médical 4 pour indiquer changement de police(Wingdings 2) et couleur rouge
Dim i As Integer, j As Integer, MonTab, ListCode As Range, MaCol
Dim Plage As Range, Cel
Set MonDico = CreateObject("Scripting.Dictionary")
'chargement des codes en dictionary
With Worksheets("code")
Set ListCode = .Range("Code")
For i = 2 To 12
MonDico(.Cells(i, 1).Value) = .Cells(i, 3)
Next
End With
'mise des données à copier en tableau
MonTab = Selection
' "traduction" des données
For i = LBound(MonTab, 1) To UBound(MonTab, 1)
For j = LBound(MonTab, 2) To UBound(MonTab, 2)
If MonTab(i, j) <> "" And MonTab(i, j) <> "WE" Then
MonTab(i, j) = MonDico(MonTab(i, j))
Else
MonTab(i, j) = ""
End If
Next
Next
'copie du tableau traduit
MaCol = Selection.Column
Cells(61, MaCol).Resize(UBound(MonTab, 1), UBound(MonTab, 2)) = MonTab
'******************* Mise en forme *******************
'chargement des symboles et couleurs associées en dictionary
With Worksheets("code")
For i = 2 To 12
MonDico(.Cells(i, 3).Value) = .Cells(i, 4)
Next
End With
'définition de la plage à traiter
Set Plage = Range("B61:BV80")
' mise en couleur des symboles
For Each Cel In Plage
If Cel.Value <> "" And Cel.Value <> "WE" Then
If MonDico(Cel.Value) = 4 Then
Cel.Font.Name = "Wingdings 2"
Cel.Font.ColorIndex = 3
Else
Cel.Font.Name = "Webdings"
Cel.Font.ColorIndex = MonDico(Cel.Value)
End If
End If
Next
End Sub