1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57
| Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, [D9:D25]) Is Nothing Then Exit Sub
Dim Plage As Range, Noms As Range, CelNom As Range, Celcouleur As Range
On Error Resume Next 'Permet d'arreter la macro sans message en d'erreur
'Set References = Range("Empty_head") 'Reference = zone avec un nom de champ içi Empty Head
'Dans notre cas de figure, il faut que la reference soit liée avec le nom de champ repris dans chaque datavalidation ce qui donne ceci
' solution pour interprétation de la fonction Indirect dans toutes les langues Excel INDIRECT-INDIRECTO-...
formule = ActiveCell.Validation.Formula1
Tabl = Split(formule, "(")
'*** pour test
Tabl(0) = "=INDIRECTO"
MsgBox "formule initiale : " & Join(Tabl, "(")
Tabl(0) = "=INDIRECT"
formule = Join(Tabl, "(")
MsgBox "formule corrigée : " & formule
'***
Set References = Range(formule)
' Set References = Range(ActiveCell.Validation.Formula1) 'Activecell.Validation.Formula1 est la commande qui permet de reprendre la formule dans la data validation de la cellule active
If Sh.Name = ("Configurator") Then 'Feuille du classeur avec liste déroulante
Set Plage = Range("D9:D25") 'Plage dans la feuille du classeur
'ElseIf Sh.Name = ("3 quadri 2005") Then 'Exemple si tu veux mettre une autre feuille ou autre plage, voir ligne suivante
'Set Plage = Range("D4:D33,H4:H34,L4:L33,P4:P34")
Else: Exit Sub
End If
'ThisWorkbook.
If Not Intersect(Target, Plage) Is Nothing Then
For Each CelNom In Intersect(Target, Plage)
For Each Celcouleur In References
If CelNom = Celcouleur Then
CelNom.Interior.ColorIndex = Celcouleur.Interior.ColorIndex
CelNom.Font.ColorIndex = Celcouleur.Font.ColorIndex
Exit For
End If
If CelNom <> Celcouleur Then
CelNom.Interior.Color = 255
End If
Next Celcouleur
Next CelNom
End If
End Sub |
Partager