Macro couleur de formes

Bonjour,

Je récupère une macro qui jusqu'à présent fonctionne très bien, simplement en voulant étendre son champ d'utilisation cela ne fonctionne pas. Je m'explique:
A l'origine la macro colorie une freeform (régions de France), fait apparaître des objets (flèches) en fonction de la valeur de chaque mois de l'année.

Aujourd'hui je souhaite utiliser exactement le meme mode fonctionnement mais j'ai rajouté une deuxième carte de France (les freeform sont nommées différemment) qui se colorie en fonction d'autres valeurs.

J'ai donc repris la meme macro et changé les valeurs (j'ai certainement du en oublier vu que cela ne fonctionne pas)

Est ce que quelqu'un pourrait m'aider svp en apportant les modifs à la macro ci dessous ?


Merci d'avance.


'Programmation moisTF (fonctionne)

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Mois As String
Dim i As Integer
Dim DR As String
Dim TxFreq, TxMoisEnCours, TxMoisPrec As Variant
Set wk = ActiveWorkbook
Set Source = wk.Sheets("2012")
Set param = wk.Sheets("parametrage TdB")
Set TDB = wk.Sheets("Tableau de bord")

Mois = TDB.Range("I8").Value
'régions
For i = 1 To 61

DR = Source.Cells(i, 1)

'Taux

TxFreq = Source.Cells(i + 10, 14)


'mois

For a = 2 To 13
If Source.Cells(i + 1, a) = Mois Then
TxMoisEnCours = Source.Cells(i + 10, a)
TxMoisPrec = Source.Cells(i + 10, a - 1)
End If
Next a
Couleur DR, TxFreq
Fleche DR, TxMoisEnCours, TxMoisPrec, Mois
i = i + 14
Next i

End Sub

'Programmation couleur TF (fonctionne)

Function Couleur(Région, Tx) As Integer
Set wk = ActiveWorkbook
Set Source = wk.Sheets("2012")
Set param = wk.Sheets("parametrage TdB")
Set TDB = wk.Sheets("Tableau de bord")

Select Case Tx
Case Is < param.Cells(3, 2)
Couleur = param.Cells(3, 3)
Case Is > param.Cells(4, 2)
Couleur = param.Cells(5, 3)
Case Else
Couleur = param.Cells(4, 3)
End Select

For b = 41 To 45
If param.Cells(b, 1) = Région Then
x = 2
Do While param.Cells(b, x) <> 0
nom = "Freeform " & param.Cells(b, x)
TDB.Shapes(nom).Fill.ForeColor.SchemeColor = Couleur
x = x + 1
Loop
End If
Next
End Function

'Programmation fleches TF (fonctionne)

Function Fleche(Région, TxEncours, TxPrec, MoisVal)
Set wk = ActiveWorkbook
Set Source = wk.Sheets("2012")
Set param = wk.Sheets("parametrage TdB")
Set TDB = wk.Sheets("Tableau de bord")

If MoisVal <> "JANVIER" Then
test = TxEncours - TxPrec
Select Case test
Case Is < 0
vtest = 1
Case Is > 0
vtest = 2
Case Is = 0
vtest = 3
End Select
Else
vtest = 0
End If

For b = 49 To 53
If param.Cells(b, 1) = Région Then
For y = 1 To 3
nom = param.Cells(48, y + 1) & " " & param.Cells(b, y + 1)
If y = vtest Then
TDB.Shapes(nom).Visible = True
Else
TDB.Shapes(nom).Visible = False
End If
Next y
End If
Next b
End Function


(CE QUI SUIT EST CE QUE JE SOUHAITE RAJOUTER MAIS NE FONCTIONNE PAS)

Private Sub Workbook_SheetChange2(ByVal Sh As Object, ByVal Target As Range)
Dim Mois As String
Dim i As Integer
Dim DR As String
Dim TxGrav, TxMoisEnCours, TxMoisPrec As Variant
Set wk = ActiveWorkbook
Set Source = wk.Sheets("2012")
Set param = wk.Sheets("parametrage TdB")
Set TDB = wk.Sheets("Tableau de bord")

Mois = TDB.Range("I8").Value
'régions
For i = 1 To 61

DR = Source.Cells(i, 1)

'Taux

TxGrav = Source.Cells(i + 11, 14)

'mois

For a = 2 To 13
If Source.Cells(i + 1, a) = Mois Then
TxMoisEnCours = Source.Cells(i + 11, a)
TxMoisPrec = Source.Cells(i + 11, a - 1)
End If
Next a
Couleur DR, TxGrav
Fleche DR, TxMoisEnCours, TxMoisPrec, Mois
i = i + 14
Next i
End Sub

'programmation couleur TG

Function Couleur2(Région, Tx) As Integer
Set wk = ActiveWorkbook
Set Source = wk.Sheets("2012")
Set param = wk.Sheets("parametrage TdB")
Set TDB = wk.Sheets("Tableau de bord")

Select Case Tx
Case Is < param.Cells(8, 2)
Couleur = param.Cells(8, 3)
Case Is > param.Cells(9, 2)
Couleur = param.Cells(10, 3)
Case Else
Couleur = param.Cells(9, 3)
End Select

For b = 58 To 62
If param.Cells(b, 1) = Région Then
x = 2
Do While param.Cells(b, x) <> 0
nom = "Freeform " & param.Cells(b, x)
TDB.Shapes(nom).Fill.ForeColor.SchemeColor = Couleur
x = x + 1
Loop
End If
Next
End Function