macro excel 2002 >> excel 97

[cafrine]

macro excel 2002 >> excel 97

Bonsoir à tous

J'ai cette macro qui fonctionne très bien sur excel 2002 mais pas sur 97.
le problème se situe au niveau de l'affichage des couleurs dans les celulles.
Si quelqu'un pouvait me l'adapter.. ca serait super.
A moins qu'il y ait une case à cocher dans excel 97...
merci.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Plage As Range, Noms As Range, CelNom As Range, Celcouleur As Range
Set References = Range("Situation") 'situation est définit dans Excel via menu/insertion/nom/définir
On Error Resume Next 'Permet d'arreter la macro sans message en d'erreur
If Sh.Name = ("1 quadri 2004") Then 'Mois correspond à la feuille "Mois" dans le classeur
Set Plage = Range("D434,H4:H32,L4:L34,P433") 'Plage dans la feuille Mois du classeur
ElseIf Sh.Name = ("2 quadri 2004") Then 'Mois correspond à la feuille "Mois" dans le classeur
Set Plage = Range("D434,H4:H33,L4:L34,P434") 'Plage dans la feuille Mois du classeur
ElseIf Sh.Name = ("3 quadri 2004") Then 'Mois correspond à la feuille "Mois" dans le classeur
Set Plage = Range("D433,H4:H34,L4:L33,P434") 'Plage dans la feuille Mois du classeur
ElseIf Sh.Name = ("1 quadri 2005") Then 'Mois correspond à la feuille "Mois" dans le classeur
Set Plage = Range("D434,H4:H31,L4:L34,P433") 'Plage dans la feuille Mois du classeur
ElseIf Sh.Name = ("2 quadri 2005") Then 'Mois correspond à la feuille "Mois" dans le classeur
Set Plage = Range("D434,H4:H33,L4:L34,P434") 'Plage dans la feuille Mois du classeur
ElseIf Sh.Name = ("3 quadri 2005") Then 'Mois correspond à la feuille "Mois" dans le classeur
Set Plage = Range("D433,H4:H34,L4:L33,P434") 'Plage dans la feuille Mois du classeur
Else: Exit Sub 'permet de sortir de la macro si la feuille active n'est pas la feuille Mois
End If
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
Next Celcouleur
Next CelNom
End If
End Sub

 

[galopin01]

Re: macro excel 2002 >> excel 97

bonsoir,
c'est encore moi. je t'ai mis une macro revue et corrigée dans mémoclic :
yapuka tester (avec les précautions habituelles...)
A+

 

[cafrine]

Re: macro excel 2002 >> excel 97

bonsoir a tous
Absent pendant qq jours, me revoila donc ...
Comme tu me l'as dis GALOPIN01, j'ai effectué le changement mais ça ne marche pas..
aucune réaction !
je joins le fichier au cas où ...
Merci
Cafrine

 

[galopin01]

Re: macro excel 2002 >> excel 97

Bonsoir,
N'ayant pas connu Excel97 il est temps que je passe la main...
J'ai vérifié que la solution de contournement d'INTERSECT était bonne, donc ce n'est pas du tout là que ça pêche.
Comme il n'y a vraiment rien d'extraordinaire dans cette macro...
Est ce que :
Private Sub Workbook_SheetChange... existait déjà dans Excel97 ?
Attendons les spécialistes...
A+

 

[michel]

Re: macro excel 2002 >> excel 97

bonsoir Cafrine , bonsoir Galopin01

Cafrine , ton classeur fonctionne aussi chez moi ( Excel2002)
L'evenement "Workbook_SheetChange" existe bien avec Excel97 , mais malheureusement est inactif lors de l'utilisation des listes de validation

tu trouveras ci-joint une solution de remplacement beaucoup moins élégante mais qui fonctionne avec Excel97 et les versions ulterieures

le principe
au lieu d'avoir une liste de validation , il faut double cliquer sur la cellule que l'on souhaite modifier
un UserForm contenant la liste de choix s'affiche à l'écran pour sélectionner une des options ( formation , maladie …etc…)

j'espere que cela pourra t'aider


bonne soirée
MichelXld

 

[cafrine]

Re: macro excel 2002 >> excel 97

bonsoir à tous,

bonsoir michel, ta solution n'est pas à quoi je pensais mais elle est très bien et surtout fonctionne. Je t'en remercie. Grâce à toi je peux enfin utiliser mon fichier .
un merci aussi à galopin01..
à bientôt
cafrine

 

[Jean-Marie]

Re: macro excel 2002 >> excel 97

Bonjour tout le monde

Une liste de validation (en XL 97 et sur Mac) ne provoque pas l'événement Change, néanmoins il y a possibilité de passer par un événement Calculate, en utilisant une formule.

En utilisant l'événement Change, nous connaissons l'adresse de la cellule qui provoquer l'action (ByVal Target As Excel.Range), mais pour un Calculate, nous n'avons pas la possibilité directement par le VBA de la connaître.

Si nous ne connaissons par cette adresse, il faudra refaire tout le tableau à chaque génération de Calculate, ce qui va ralentir considérablement les temps de réponse d'Excel, et au final l'utilisateur mettra à la corbeille le fichier.

En utilisant la formule dans une feuille de calcul =Cellule("adresse"), nous fessons une pierre deux coup, elle provoque l'événement, et retourne l'adresse de la cellule qui a été modifiée en dernier.

Dans le code ci-joint, j'ai placé la formule =CELLULE("ADRESSE") dans la cellule B1 de la feuille situation.

Option Explicit

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Dim vTarget As String
Dim vFich As String
Dim vfeuil As String
Dim vCell As String
Dim Target As Range
Dim Plage As Range, Noms As Range, CelNom As Range, Celcouleur As Range, References As Range

'=cellule("adresse" retourne la référence de la cellule sous forme de texte
'il faut décomposer ce champ pour la suite de la macro
'cette adresse sera composée ou non du nom de la feuille suivant l'emplacement de la cellule
' - pas de nom de feuille, la référence de la cellule ce situe sur la feuille situation
' - nom du fichier et de la feuille, dans tout les autres feuille
' peut-être composée :
' - entre [ ] pour les classeurs
' - puis Nom de la feuille terminée par !
' - puis de la référence de la cellule
vTarget = Worksheets("Situation").Range("B1")
If InStr(1, vTarget, "[") = 0 Then Exit Sub 'Situé sur la feuille Situation
vTarget = WorksheetFunction.Substitute(vTarget, "'", "") 'supprime les carcatères ' pouvant existés
vFich = Mid(vTarget, 2, InStr(1, vTarget, "]") - 2) 'récupération du nom du fichier
If vFich <> ThisWorkbook.Name Then Exit Sub
vfeuil = Mid(vTarget, InStr(1, vTarget, "]") + 1, Len(vTarget))
vfeuil = Mid(vfeuil, 1, InStr(1, vfeuil, "!") - 1)
vCell = Mid(vTarget, InStr(1, vTarget, "!") + 1, Len(vfeuil))
Set Target = Range(vCell) 'Conversion de String en Range

Set References = Range("Situation")
If vfeuil = ("1 quadri 2004") Then 'Mois correspond à la feuille "Mois" dans le classeur
Set Plage = Range("D434,H4:H32,L4:L34,P433") 'Plage dans la feuille Mois du classeur
ElseIf vfeuil = ("2 quadri 2004") Then 'Mois correspond à la feuille "Mois" dans le classeur
Set Plage = Range("D434,H4:H33,L4:L34,P434") 'Plage dans la feuille Mois du classeur
ElseIf vfeuil = ("3 quadri 2004") Then 'Mois correspond à la feuille "Mois" dans le classeur
Set Plage = Range("D433,H4:H34,L4:L33,P434") 'Plage dans la feuille Mois du classeur
ElseIf vfeuil = ("1 quadri 2005") Then 'Mois correspond à la feuille "Mois" dans le classeur
Set Plage = Range("D434,H4:H31,L4:L34,P433") 'Plage dans la feuille Mois du classeur
ElseIf vfeuil = ("2 quadri 2005") Then 'Mois correspond à la feuille "Mois" dans le classeur
Set Plage = Range("D434,H4:H33,L4:L34,P434") 'Plage dans la feuille Mois du classeur
ElseIf vfeuil = ("3 quadri 2005") Then 'Mois correspond à la feuille "Mois" dans le classeur
Set Plage = Range("D433,H4:H34,L4:L33,P434") 'Plage dans la feuille Mois du classeur
ElseIf vfeuil = ("1 quadri 2006") Then 'Mois correspond à la feuille "Mois" dans le classeur
Set Plage = Range("D434,H4:H31,L4:L34,P433") 'Plage dans la feuille Mois du classeur
ElseIf vfeuil = ("2 quadri 2006") Then 'Mois correspond à la feuille "Mois" dans le classeur
Set Plage = Range("D434,H4:H33,L4:L34,P434") 'Plage dans la feuille Mois du classeur
ElseIf vfeuil = ("3 quadri 2006") Then 'Mois correspond à la feuille "Mois" dans le classeur
Set Plage = Range("D433,H4:H34,L4:L33,P434") 'Plage dans la feuille Mois du classeur
Else: Exit Sub 'permet de sortir de la macro si la feuille active n'est pas la feuille Mois
End If
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
Next Celcouleur
Next CelNom
End If
End Sub

@+Jean-Marie