Logo GNT
Actualités Tests & Guides Bons Plans
GTA 6 iPhone 17 Copilot Switch 2 Temu ChatGPT Tesla
OVH Cloud OVH Cloud
Entraide Applications Microsoft Office Excel Colorer les cellules dépendantes

Colorer les cellules dépendantes

8 réponses
Avatar
tipi
Bonjour,

Je cherche un code qui permette de colorer les cellules dépendantes d'une
cellule.
Les cellules dépendantes peuvent se trouver sur d'autres feuilles du même
classeur.

Merci
Signaler un problème avec ce contenu

8 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
Jacky
Bonjour,

La Mfc ne permettant pas de faire référence à une autre feuille.
Par VBA par exemple:
'---------
Sub jj()
If Sheets("Feuil3").Range("a1") <= 0 Then
Sheets("Feuil1").Range("a1").Interior.ColorIndex = 3
End Sub
'---------
Met la couleur rouge de A1 feuil1 si a1 de feuil3 >=0

Salutations
jj

"tipi" a écrit dans le message de
news:
Bonjour,

Je cherche un code qui permette de colorer les cellules dépendantes d'une
cellule.
Les cellules dépendantes peuvent se trouver sur d'autres feuilles du même
classeur.

Merci





Avatar
tipi
Merci

Au fait je cherche à affecter une couleur à toutes les cellules qui se
trouvent partout dans le classeur et qui contribuent au résultat de la
cellule A1 de la feuille 1 par exemple.
Le code se déclencherait en étant positionné sur A1 de la feuille 1.

Merci



"Jacky" a écrit dans le message de news:

Bonjour,

La Mfc ne permettant pas de faire référence à une autre feuille.
Par VBA par exemple:
'---------
Sub jj()
If Sheets("Feuil3").Range("a1") <= 0 Then
Sheets("Feuil1").Range("a1").Interior.ColorIndex = 3
End Sub
'---------
Met la couleur rouge de A1 feuil1 si a1 de feuil3 >=0

Salutations
jj

"tipi" a écrit dans le message de
news:
Bonjour,

Je cherche un code qui permette de colorer les cellules dépendantes d'une
cellule.
Les cellules dépendantes peuvent se trouver sur d'autres feuilles du même
classeur.

Merci









Avatar
Jacky
Re....
les cellules qui se trouvent partout dans le classeur
Tu es sur de cela???

Cela fera plus de 50 000 000 cellules a vérifier pour 3 feuilles
Vaudrais mieux définir des plages, non ??

JJ

"tipi" a écrit dans le message de
news:
Merci

Au fait je cherche à affecter une couleur à toutes les cellules qui se
trouvent partout dans le classeur et qui contribuent au résultat de la
cellule A1 de la feuille 1 par exemple.
Le code se déclencherait en étant positionné sur A1 de la feuille 1.

Merci



"Jacky" a écrit dans le message de news:

Bonjour,

La Mfc ne permettant pas de faire référence à une autre feuille.
Par VBA par exemple:
'---------
Sub jj()
If Sheets("Feuil3").Range("a1") <= 0 Then
Sheets("Feuil1").Range("a1").Interior.ColorIndex = 3
End Sub
'---------
Met la couleur rouge de A1 feuil1 si a1 de feuil3 >=0

Salutations
jj

"tipi" a écrit dans le message de
news:
Bonjour,

Je cherche un code qui permette de colorer les cellules dépendantes
d'une



cellule.
Les cellules dépendantes peuvent se trouver sur d'autres feuilles du
même



classeur.

Merci













Avatar
JB
Bonjour,

On peut avec les MFC référencer d'autres feuilles en utilisant des
noms de champ

http://www.excelabo.net/compteclic.php?nom=jb-formatsconditionnels

Onglets Prévu/réalisé ou BD1/BD2 ou BDplanning

Cordialement JB
Avatar
tipi
Salut,

J'ai pensé à l'enregistreur avec 1 cellule et 2 cellules antécédentes et ça
donne ça :

Sub depend()

Selection.ShowPrecedents
ActiveCell.NavigateArrow TowardPrecedent:=True, ArrowNumber:=1,
LinkNumber _
:=1
With Selection.Interior
.ColorIndex = 8
.Pattern = xlSolid
End With
ActiveSheet.Previous.Select
ActiveCell.NavigateArrow TowardPrecedent:=True, ArrowNumber:=1,
LinkNumber _
:=2
With Selection.Interior
.ColorIndex = 8
.Pattern = xlSolid
End With
End Sub

Si j'arrive à faire une boucle sur LinkNumber en en connaissant le nombre,
je crois que le tour sera joué

Est-ce que je me trompe ?

Merci


"JB" a écrit dans le message de news:

Bonjour,

On peut avec les MFC référencer d'autres feuilles en utilisant des
noms de champ

http://www.excelabo.net/compteclic.php?nom=jb-formatsconditionnels

Onglets Prévu/réalisé ou BD1/BD2 ou BDplanning

Cordialement JB
Avatar
anonymousA
Bonjour

Quelquechose qui doit ressembler à ce que tu demandes et est à
adpater à ton cas de figure.

Sub Constituer_les_précédents()

'adaptation d'une procédure (FindPrecedents)
'written by Bill Manville, revised by Paul S.
'mpep, August 14, 2001
'Cette procédure détermine les cellules ( y.c dans un autre fichier
et y.c si un nom
'de plage a été donné) d'une cellule contenant une formule

Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim bNewArrow As Boolean, tabladdress()
Dim nbaddress

Set cell = ActiveCell
'Application.ScreenUpdating = False
cell.Select
ActiveCell.ShowPrecedents
Set rLast = cell
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do 'on entre de toute façon une 1ere fois dans la boucle
Do 'on entre de toute façon une 1ere fois dans la boucle
Application.Goto rLast
On Error Resume Next 'pour se prémunir d'une référence à
une cellule d'un classeur fermé
'et aussi terminer le processus s'il n'y a pas de nouvelle
flèche
'Navigatearrow fait se déplacer l'activation vers le range
source l'un après l'autre si
'on porte TowardPrecedent:=True sinon si on met false c'est
vers le dépendent
ActiveCell.NavigateArrow TowardPrecedent:=True,
ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
'si erreur on sort
If Err.Number > 0 Then Exit Do
On Error GoTo 0

'à l'issue de la 2eme boucle boucle si l'addresse en cours est
l'adresse
'de la cellule contenant la formule,il faut donc sortir. On
compare les addresses
'complètes pour eviter de confondre p.e Feuil1!$A$1 avec
Feuil2!$A$1
'il vaut mieux mettre selection que ActiveCell car si
ActiveCell.NavigateArrow TowardPrecedent
'renvoie une plage de cellules ( ex: recherchev(C4;toto;1;FAUX)
renvoie vers uen plage
'de cellules nommée toto, alors selection renverra l'addresse
complète tandis que
'activecell renverra seulement la 1ere cellule de la plage toto
'If rLast.Address(external:=True) =
ActiveCell.Address(external:=True) Then Exit Do
If rLast.Address(external:=True) =
Selection.Address(external:=True) Then Exit Do
nbaddress = nbaddress + 1
ReDim Preserve tabladdress(1 To nbaddress)
tabladdress(nbaddress) = ActiveCell.Address(external:=True)
bNewArrow = False 'remise à False pour la 1ere boucle Do pour
quand on va sortir
'on ne soit pas éjecté de la 1ere boucle
Do. Cette ejection ne
'doit se produire que si err.number était
<>0
iLinkNum = iLinkNum + 1 ' Essai d'un nouveau lien sur la même
flèche

Loop
If bNewArrow Then Exit Do 'si err.number était <> 0 , on sort

iLinkNum = 1 'on remet le lien à 1 puisqu'on va attaquer une autre
flèche
bNewArrow = True
iArrowNum = iArrowNum + 1 'essai autre flèche

Loop

rLast.Parent.ClearArrows 'on efface toutes les flèches
Application.Goto rLast 'on retourne à la cellule contenant la
formule

'une fois que l'on a constitué le tableau tabladdress, il suffit de
le parcourir
'pour conniatre les addresses exactes des cellules
'If bNewArrow Then Exit Sub 'au cas où il n'y ait pas du tout de
formules ca planterait avec
'la boucle for suivante

'tester avant si tabaddress contient des éléments autrement
plantage
'de Application.Goto Range(tabladdress(1))
For i = LBound(tabladdress) To UBound(tabladdress)
MsgBox tabladdress(i)
Next

'si on veut s'y rendre p.e à la 1ere addresse
Application.Goto Range(tabladdress(1))

End Sub
Avatar
tipi
Merci

je vais essayer d'adapter

A bientôt

"anonymousA" a écrit dans le message de news:

Bonjour

Quelquechose qui doit ressembler à ce que tu demandes et est à
adpater à ton cas de figure.

Sub Constituer_les_précédents()

'adaptation d'une procédure (FindPrecedents)
'written by Bill Manville, revised by Paul S.
'mpep, August 14, 2001
'Cette procédure détermine les cellules ( y.c dans un autre fichier
et y.c si un nom
'de plage a été donné) d'une cellule contenant une formule

Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim bNewArrow As Boolean, tabladdress()
Dim nbaddress

Set cell = ActiveCell
'Application.ScreenUpdating = False
cell.Select
ActiveCell.ShowPrecedents
Set rLast = cell
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do 'on entre de toute façon une 1ere fois dans la boucle
Do 'on entre de toute façon une 1ere fois dans la boucle
Application.Goto rLast
On Error Resume Next 'pour se prémunir d'une référence à
une cellule d'un classeur fermé
'et aussi terminer le processus s'il n'y a pas de nouvelle
flèche
'Navigatearrow fait se déplacer l'activation vers le range
source l'un après l'autre si
'on porte TowardPrecedent:=True sinon si on met false c'est
vers le dépendent
ActiveCell.NavigateArrow TowardPrecedent:=True,
ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
'si erreur on sort
If Err.Number > 0 Then Exit Do
On Error GoTo 0

'à l'issue de la 2eme boucle boucle si l'addresse en cours est
l'adresse
'de la cellule contenant la formule,il faut donc sortir. On
compare les addresses
'complètes pour eviter de confondre p.e Feuil1!$A$1 avec
Feuil2!$A$1
'il vaut mieux mettre selection que ActiveCell car si
ActiveCell.NavigateArrow TowardPrecedent
'renvoie une plage de cellules ( ex: recherchev(C4;toto;1;FAUX)
renvoie vers uen plage
'de cellules nommée toto, alors selection renverra l'addresse
complète tandis que
'activecell renverra seulement la 1ere cellule de la plage toto
'If rLast.Address(external:=True) ActiveCell.Address(external:=True) Then Exit Do
If rLast.Address(external:=True) Selection.Address(external:=True) Then Exit Do
nbaddress = nbaddress + 1
ReDim Preserve tabladdress(1 To nbaddress)
tabladdress(nbaddress) = ActiveCell.Address(external:=True)
bNewArrow = False 'remise à False pour la 1ere boucle Do pour
quand on va sortir
'on ne soit pas éjecté de la 1ere boucle
Do. Cette ejection ne
'doit se produire que si err.number était
<>0
iLinkNum = iLinkNum + 1 ' Essai d'un nouveau lien sur la même
flèche

Loop
If bNewArrow Then Exit Do 'si err.number était <> 0 , on sort

iLinkNum = 1 'on remet le lien à 1 puisqu'on va attaquer une autre
flèche
bNewArrow = True
iArrowNum = iArrowNum + 1 'essai autre flèche

Loop

rLast.Parent.ClearArrows 'on efface toutes les flèches
Application.Goto rLast 'on retourne à la cellule contenant la
formule

'une fois que l'on a constitué le tableau tabladdress, il suffit de
le parcourir
'pour conniatre les addresses exactes des cellules
'If bNewArrow Then Exit Sub 'au cas où il n'y ait pas du tout de
formules ca planterait avec
'la boucle for suivante

'tester avant si tabaddress contient des éléments autrement
plantage
'de Application.Goto Range(tabladdress(1))
For i = LBound(tabladdress) To UBound(tabladdress)
MsgBox tabladdress(i)
Next

'si on veut s'y rendre p.e à la 1ere addresse
Application.Goto Range(tabladdress(1))

End Sub
Avatar
tipi
voici la macro après adaptation (ça applique la couleur de la cellule active
aux autres cellules) :

Sub FindPrecedents()
' written by Bill Manville
' With edits from PaulS
' this procedure finds the cells which are the direct precedents of the
active cell
Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim stMsg As String
Dim bNewArrow As Boolean
Application.ScreenUpdating = False
gamba = ActiveCell.Interior.ColorIndex
ActiveCell.ShowPrecedents
Set rLast = ActiveCell
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow TowardPrecedent:=True,
ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
If Err.Number > 0 Then Exit Do
On Error GoTo 0
If rLast.Address(external:=True) =
ActiveCell.Address(external:=True) Then Exit Do
bNewArrow = False
If rLast.Worksheet.Parent.Name =
ActiveCell.Worksheet.Parent.Name Then
If rLast.Worksheet.Name = ActiveCell.Parent.Name Then
' local
stMsg = stMsg & vbNewLine & Selection.Address
Selection.Interior.ColorIndex = gamba
Else
stMsg = stMsg & vbNewLine & "'" & Selection.Parent.Name
& "'!" & Selection.Address
Selection.Interior.ColorIndex = gamba
End If
Else
' external
stMsg = stMsg & vbNewLine &
Selection.Address(external:=True)
Selection.Interior.ColorIndex = gamba
End If
iLinkNum = iLinkNum + 1 ' try another link
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1 'try another arrow
Loop
rLast.Parent.ClearArrows
Application.Goto rLast

Exit Sub
End Sub


Merci


"tipi" a écrit dans le message de news:

Merci

je vais essayer d'adapter

A bientôt

"anonymousA" a écrit dans le message de news:

Bonjour

Quelquechose qui doit ressembler à ce que tu demandes et est à
adpater à ton cas de figure.

Sub Constituer_les_précédents()

'adaptation d'une procédure (FindPrecedents)
'written by Bill Manville, revised by Paul S.
'mpep, August 14, 2001
'Cette procédure détermine les cellules ( y.c dans un autre fichier
et y.c si un nom
'de plage a été donné) d'une cellule contenant une formule

Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim bNewArrow As Boolean, tabladdress()
Dim nbaddress

Set cell = ActiveCell
'Application.ScreenUpdating = False
cell.Select
ActiveCell.ShowPrecedents
Set rLast = cell
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do 'on entre de toute façon une 1ere fois dans la boucle
Do 'on entre de toute façon une 1ere fois dans la boucle
Application.Goto rLast
On Error Resume Next 'pour se prémunir d'une référence à
une cellule d'un classeur fermé
'et aussi terminer le processus s'il n'y a pas de nouvelle
flèche
'Navigatearrow fait se déplacer l'activation vers le range
source l'un après l'autre si
'on porte TowardPrecedent:=True sinon si on met false c'est
vers le dépendent
ActiveCell.NavigateArrow TowardPrecedent:=True,
ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
'si erreur on sort
If Err.Number > 0 Then Exit Do
On Error GoTo 0

'à l'issue de la 2eme boucle boucle si l'addresse en cours est
l'adresse
'de la cellule contenant la formule,il faut donc sortir. On
compare les addresses
'complètes pour eviter de confondre p.e Feuil1!$A$1 avec
Feuil2!$A$1
'il vaut mieux mettre selection que ActiveCell car si
ActiveCell.NavigateArrow TowardPrecedent
'renvoie une plage de cellules ( ex: recherchev(C4;toto;1;FAUX)
renvoie vers uen plage
'de cellules nommée toto, alors selection renverra l'addresse
complète tandis que
'activecell renverra seulement la 1ere cellule de la plage toto
'If rLast.Address(external:=True) > ActiveCell.Address(external:=True) Then Exit Do
If rLast.Address(external:=True) > Selection.Address(external:=True) Then Exit Do
nbaddress = nbaddress + 1
ReDim Preserve tabladdress(1 To nbaddress)
tabladdress(nbaddress) = ActiveCell.Address(external:=True)
bNewArrow = False 'remise à False pour la 1ere boucle Do pour
quand on va sortir
'on ne soit pas éjecté de la 1ere boucle
Do. Cette ejection ne
'doit se produire que si err.number était
<>0
iLinkNum = iLinkNum + 1 ' Essai d'un nouveau lien sur la même
flèche

Loop
If bNewArrow Then Exit Do 'si err.number était <> 0 , on sort

iLinkNum = 1 'on remet le lien à 1 puisqu'on va attaquer une autre
flèche
bNewArrow = True
iArrowNum = iArrowNum + 1 'essai autre flèche

Loop

rLast.Parent.ClearArrows 'on efface toutes les flèches
Application.Goto rLast 'on retourne à la cellule contenant la
formule

'une fois que l'on a constitué le tableau tabladdress, il suffit de
le parcourir
'pour conniatre les addresses exactes des cellules
'If bNewArrow Then Exit Sub 'au cas où il n'y ait pas du tout de
formules ca planterait avec
'la boucle for suivante

'tester avant si tabaddress contient des éléments autrement
plantage
'de Application.Goto Range(tabladdress(1))
For i = LBound(tabladdress) To UBound(tabladdress)
MsgBox tabladdress(i)
Next

'si on veut s'y rendre p.e à la 1ere addresse
Application.Goto Range(tabladdress(1))

End Sub