Bonjour à tous,
je voudrai que sur mon fichier, le texte change de couleur lorsque nous modifions la cellule.
Je vous met ci-joins le code VBA utiliser mais le seul problème c'est lorsque que je veux insérer une nouvelle ligne, il y a un bug dans le code à cette ligne "
If Not Intersect(Cible, Range("A6:G354")) Is Nothing Then".
Quelqu'un saurait-il m'aider? Merci d'avance
Cdlt
Option Explicit
Dim MemChange As Variant
Private Sub Entree_Click()
Application.EnableEvents = False ' Pour Saisie
End Sub
Private Sub Modif_Click()
Application.EnableEvents = True ' Pour modif.
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Cible As Range, Ret As Boolean)
If Not Intersect(Cible, Range("A6:G354")) Is Nothing Then
Range("A1").Select ' Empêche la modification de couleur si double-clic dans une cellule
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Cible As Range)
If Not Intersect(Cible, Range("A6:G354")) Is Nothing Then
MemChange = Cible.Value ' Met en mémoire la valeur avant modif.
End If
End Sub
Private Sub Worksheet_Change(ByVal Cible As Range)
Dim Car As String
Dim Cpt As Long
Dim MotsAvant() As String
Dim MotsApres() As String
Dim Mot As String
Dim i As Long
Dim j As Long
Dim Dep As Long
Dim Lng As Long
Dim Rep As Long
If Not Intersect(Cible, Range("A6:G354")) Is Nothing Then
' Mise en tableau des mots de la cellule avant modif
i = 0
For Cpt = 1 To Len(MemChange) + 1
Car = Mid(MemChange, Cpt, 1)
If Car <> " " And Cpt <> Len(MemChange) + 1 Then
Mot = Mot + Car
Else
i = i + 1
ReDim Preserve MotsAvant(1 To i)
MotsAvant(i) = Mot
Mot = ""
End If
Next Cpt
' Mise en tableau des mots de la cellule après modif
i = 0
For Cpt = 1 To Len(Cible) + 1
Car = Mid(Cible, Cpt, 1)
If Car <> " " And Cpt <> Len(Cible) + 1 Then
Mot = Mot + Car
Else
i = i + 1
ReDim Preserve MotsApres(1 To i)
MotsApres(i) = Mot
Mot = ""
End If
Next Cpt
' Traitement
If UBound(MotsAvant) <> UBound(MotsApres) Then ' Si Nb. mots différent, on colorie le fond de cellule
Cible.Interior.ColorIndex = 3
Else ' Sinon si Nb. de mots identique
For i = 1 To UBound(MotsAvant) ' Pour tous les mots on vérifie si le
If MotsApres(i) <> MotsAvant(i) Then ' mot après est différent du mot avant
If i = 1 Then ' Si c'est le premier mot
Lng = Len(MotsApres(1)) ' Longueur = long. 1er mot (à colorier)
Dep = 0 ' Départ = au 1er caractère
Else ' Pour le deuxième mot et les suivants
Lng = Len(MotsApres(i)) ' Longueur = long. du mot à colorier
Dep = 0 ' RAZ décalage du départ
For j = i - 1 To 1 Step -1
Dep = Dep + Len(MotsApres(j)) + 1 ' Décalage du départ = Somme des "longueur + 1 espace" de tous les mots précédents
Next j
Dep = Dep + 1 ' Départ = position suivante
End If
Cible.Characters(Start:=Dep, Length:=Lng).Font.ColorIndex = 3 ' On colorie la partie modifiée suivant valeurs calculées ci-dessus
End If
Next i
End If
End If
End Sub
je voudrai que sur mon fichier, le texte change de couleur lorsque nous modifions la cellule.
Je vous met ci-joins le code VBA utiliser mais le seul problème c'est lorsque que je veux insérer une nouvelle ligne, il y a un bug dans le code à cette ligne "
If Not Intersect(Cible, Range("A6:G354")) Is Nothing Then".
Quelqu'un saurait-il m'aider? Merci d'avance
Cdlt
Option Explicit
Dim MemChange As Variant
Private Sub Entree_Click()
Application.EnableEvents = False ' Pour Saisie
End Sub
Private Sub Modif_Click()
Application.EnableEvents = True ' Pour modif.
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Cible As Range, Ret As Boolean)
If Not Intersect(Cible, Range("A6:G354")) Is Nothing Then
Range("A1").Select ' Empêche la modification de couleur si double-clic dans une cellule
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Cible As Range)
If Not Intersect(Cible, Range("A6:G354")) Is Nothing Then
MemChange = Cible.Value ' Met en mémoire la valeur avant modif.
End If
End Sub
Private Sub Worksheet_Change(ByVal Cible As Range)
Dim Car As String
Dim Cpt As Long
Dim MotsAvant() As String
Dim MotsApres() As String
Dim Mot As String
Dim i As Long
Dim j As Long
Dim Dep As Long
Dim Lng As Long
Dim Rep As Long
If Not Intersect(Cible, Range("A6:G354")) Is Nothing Then
' Mise en tableau des mots de la cellule avant modif
i = 0
For Cpt = 1 To Len(MemChange) + 1
Car = Mid(MemChange, Cpt, 1)
If Car <> " " And Cpt <> Len(MemChange) + 1 Then
Mot = Mot + Car
Else
i = i + 1
ReDim Preserve MotsAvant(1 To i)
MotsAvant(i) = Mot
Mot = ""
End If
Next Cpt
' Mise en tableau des mots de la cellule après modif
i = 0
For Cpt = 1 To Len(Cible) + 1
Car = Mid(Cible, Cpt, 1)
If Car <> " " And Cpt <> Len(Cible) + 1 Then
Mot = Mot + Car
Else
i = i + 1
ReDim Preserve MotsApres(1 To i)
MotsApres(i) = Mot
Mot = ""
End If
Next Cpt
' Traitement
If UBound(MotsAvant) <> UBound(MotsApres) Then ' Si Nb. mots différent, on colorie le fond de cellule
Cible.Interior.ColorIndex = 3
Else ' Sinon si Nb. de mots identique
For i = 1 To UBound(MotsAvant) ' Pour tous les mots on vérifie si le
If MotsApres(i) <> MotsAvant(i) Then ' mot après est différent du mot avant
If i = 1 Then ' Si c'est le premier mot
Lng = Len(MotsApres(1)) ' Longueur = long. 1er mot (à colorier)
Dep = 0 ' Départ = au 1er caractère
Else ' Pour le deuxième mot et les suivants
Lng = Len(MotsApres(i)) ' Longueur = long. du mot à colorier
Dep = 0 ' RAZ décalage du départ
For j = i - 1 To 1 Step -1
Dep = Dep + Len(MotsApres(j)) + 1 ' Décalage du départ = Somme des "longueur + 1 espace" de tous les mots précédents
Next j
Dep = Dep + 1 ' Départ = position suivante
End If
Cible.Characters(Start:=Dep, Length:=Lng).Font.ColorIndex = 3 ' On colorie la partie modifiée suivant valeurs calculées ci-dessus
End If
Next i
End If
End If
End Sub
