changement de couleur d'une cellule seulement à sa deuxième modification

sebbbbb

XLDnaute Impliqué
bonjour
j'ai cherché pas mal dans les forums sans succès.
je souhaiterai que cellule E15 change de couleur non pas lorsque l'on écrit dedans pour la 1ere fois mais seulement à la deuxième.
en résumé si j'écrit des données en E15 pour le 1ere fois celles ci sont de couleur rouge et si je fais un modif les données apparaissent en noir.
je précise que les MFC ne sont pas possibles car je ne sais pas à l'avnce ce qui pourra être inscrit
un grand merci par avance
seb
 

job75

XLDnaute Barbatruc
Bonjour sebbbbb, DoubleZero :)

Mémorisation dans un nom défini :
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
With [E15] 'cellule à adapter éventuellement
    If Not Intersect(Target, .Cells) Is Nothing And CStr(.Value) <> "" Then
        If IsNumeric(Evaluate("Mem_" & .Address(0, 0))) Then
            .Font.ColorIndex = 1
        Else
            .Font.ColorIndex = 3
            ThisWorkbook.Names.Add "Mem_" & .Address(0, 0), 1 'nom défini
        End If
    End If
End With
End Sub
A+
 

job75

XLDnaute Barbatruc
Re,

Si l'on veut que le nom défini stocke le nombre de modifications (effacements non comptés) :
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
With [E15] 'cellule à adapter éventuellement
    If Not Intersect(Target, .Cells) Is Nothing And CStr(.Value) <> "" Then
        If IsNumeric(Evaluate("Mem_" & .Address(0, 0))) Then
            .Font.ColorIndex = 1
            ThisWorkbook.Names.Add "Mem_" & .Address(0, 0), Evaluate("Mem_" & .Address(0, 0)) + 1
        Else
            .Font.ColorIndex = 3
            ThisWorkbook.Names.Add "Mem_" & .Address(0, 0), 1 'nom défini
        End If
    End If
End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With [E15] 'cellule à adapter éventuellement
    If Not Intersect(Target, .Cells) Is Nothing And IsNumeric(Evaluate("Mem_" & .Address(0, 0))) Then
        Cancel = True
        If CStr(.Value) = "" Or Evaluate("Mem_" & .Address(0, 0)) = 1 Then
            MsgBox "Nombre de modifications : " & Evaluate("Mem_" & .Address(0, 0)), , .Address(0, 0)
        Else
            If MsgBox("Nombre de modifications : " & Evaluate("Mem_" & .Address(0, 0)) _
                & vbLf & vbLf & "Voulez-vous réinitialiser le comptage ?", 4, .Address(0, 0)) = 6 Then _
                    ThisWorkbook.Names.Add "Mem_" & .Address(0, 0), 1: .Font.ColorIndex = 3
        End If
    End If
End With
End Sub
Le double-clic sur E15 permet de réinitialiser le comptage.

A+
 

laetitia90

XLDnaute Barbatruc
bonjour toutes :):), tous:):)
eventuellement manipuler un boolean

VB:
Dim x As Boolean
Private Sub Worksheet_Change(ByVal T As Range)
If Not Application.Intersect(T, [E15]) Is Nothing And T.Count = 1 And T <> "" Then _
T.Font.ColorIndex = IIf(x = 0, 3, 1): x = 1
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal T As Range, Cancel As Boolean)
x = 0
End Sub
 

job75

XLDnaute Barbatruc
Bonjour sebbbbb, DoubleZero, Laetitia, Si..., le forum,

Avec vos solutions Laetitia et Si... les informations mémorisées sont perdues à la fermeture du fichier.

Vous me direz qu'un nom défini peut être supprimé, c'est vrai mais on peut alors le masquer.

Bonne journée.
 

sebbbbb

XLDnaute Impliqué
bonjour a toutes et tous
double zero ton code me semble trs bien merci. si je comprends bien il faut que j'ajoute une feuille cachée appelé mem. est ce bien celà ?
y a t il moyen de se passer de cette feuille et mettre le lien sur le même onglet mais caché éventuellement ?

Job75 : connaissant tes capacités, nul doute que ton code doit être au top. mais remplace t il celui de double zero dans son onglet (faisant ref à l'onglet mem) ou quelque chose de completement différent ?
ou l'intégrer stp ?

un grand merci a vous tous
seb
 

DoubleZero

XLDnaute Barbatruc
Bonjour, le Fil :D, le Forum,
... double zero.... si je comprends bien il faut que j'ajoute une feuille cachée appelé mem... y a t il moyen de se passer de cette feuille et mettre le lien sur le même onglet mais caché éventuellement ?...
Une nouvelle version en pièce jointe.

A bientôt:)
 

Pièces jointes

  • 00 - sebbbbb - Modification repérer v3 .xlsm
    29.1 KB · Affichages: 44

Discussions similaires

Statistiques des forums

Discussions
312 112
Messages
2 085 415
Membres
102 885
dernier inscrit
AISSOU