Modifier une macro
Bonjour
J'ai une macro dans un fichier excel que mon prédécesseur avait mis en place, elle fonctionne bien mais n'est plus vraiment a jour car des nouvelles données sont a prendre en compte.
Je voudrais rajouter dans cette macro :
-Si les cellules en P ou en R ou en T contiennent un "/" deviennent verte comme les autres.
et
- et, sur le même principe de comparaison déjà existant, avoir une nouvelle comparaison entre les colonnes O et Q; Q et S; S et U, pour que si la colonne de de gauche a une date mais que celle de droite est vide passe en orange si j+2 et rouge si J+3.
Merci pour votre aide ;)
Voici la macro en question:
Sub ColorationTCD()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long, j As Long
Dim delai As Long
Dim cols As Variant
Dim colGauche As String, colDroite As String
' Définir la feuille "TCD"
Set ws = ThisWorkbook.Sheets("TCD")
' Trouver la dernière ligne utilisée dans la colonne N
lastRow = ws.Cells(ws.Rows.Count, "N").End(xlUp).Row
' Colonnes à comparer et à colorer
cols = Array("N", "O", "P", "Q", "R", "S", "T", "U")
' Parcours de toutes les lignes avec données
For i = 2 To lastRow ' Ligne 1 = en-têtes supposées
' ***** 1. Coloration verte si la cellule contient une date *****
For j = 0 To UBound(cols)
If IsDate(ws.Range(cols(j) & i).Value) Then
' Vert pastel
ws.Range(cols(j) & i).Interior.Color = RGB(198, 239, 206)
Else
ws.Range(cols(j) & i).Interior.ColorIndex = xlNone
End If
Next j
' ***** 2. Comparaison successive entre colonnes *****
For j = 0 To UBound(cols) - 1
colGauche = cols(j)
colDroite = cols(j + 1)
' Si la cellule de gauche contient une date
If IsDate(ws.Range(colGauche & i).Value) Then
' Si la cellule de droite est vide
If IsEmpty(ws.Range(colDroite & i).Value) Or ws.Range(colDroite & i).Value = "" Then
' Calcul du délai en jours entre aujourd'hui et la date de gauche
delai = Date - ws.Range(colGauche & i).Value
' Coloration selon le délai
If delai >= 2 And delai < 3 Then
' Orange pastel
ws.Range(colDroite & i).Interior.Color = RGB(255, 229, 153)
ElseIf delai >= 3 Then
' Rouge pastel
ws.Range(colDroite & i).Interior.Color = RGB(255, 199, 206)
End If
End If
End If
Next j
Next i
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("N:U")) Is Nothing Then
Application.EnableEvents = False
Call ColorationTCD
Application.EnableEvents = True
End If
End Subedit moderation : code mis entre balises code via le bouton "</>", merci d'y penser à l'avenir
Bonjour
A tester si cela convient passe le sujet en résolu
Sub ColorationTCD()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long, j As Long
Dim delai As Long
Dim cols As Variant
Dim colGauche As String, colDroite As String
' Définir la feuille "TCD"
Set ws = ThisWorkbook.Sheets("TCD")
' Trouver la dernière ligne utilisée dans la colonne N
lastRow = ws.Cells(ws.Rows.Count, "N").End(xlUp).Row
' Colonnes à comparer et à colorer
cols = Array("N", "O", "P", "Q", "R", "S", "T", "U")
' Parcours de toutes les lignes avec données
For i = 2 To lastRow ' Ligne 1 = en-têtes supposées
' Coloration verte si la cellule contient une date ou un "/"
For j = 0 To UBound(cols)
If IsDate(ws.Range(cols(j) & i).Value) Or InStr(ws.Range(cols(j) & i).Value, "/") > 0 Then
ws.Range(cols(j) & i).Interior.Color = RGB(198, 239, 206) ' Vert pastel
Else
ws.Range(cols(j) & i).Interior.ColorIndex = xlNone
End If
Next j
' Comparaison successive entre colonnes
For j = 0 To UBound(cols) - 1
colGauche = cols(j)
colDroite = cols(j + 1)
' Si la cellule de gauche contient une date
If IsDate(ws.Range(colGauche & i).Value) Then
' Si la cellule de droite est vide
If IsEmpty(ws.Range(colDroite & i).Value) Then
' Calcul du délai en jours entre aujourd'hui et la date de gauche
delai = Date - ws.Range(colGauche & i).Value
' Coloration selon le délai
If delai = 2 Then
ws.Range(colDroite & i).Interior.Color = RGB(255, 229, 153) ' Orange pastel
ElseIf delai >= 3 Then
ws.Range(colDroite & i).Interior.Color = RGB(255, 199, 206) ' Rouge pastel
End If
End If
End If
Next j
Next i
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("N:U")) Is Nothing Then
Application.EnableEvents = False
Call ColorationTCD
Application.EnableEvents = True
End If
End SubJ'ai ce message d'erreur
A tester
Sub ColorationTCD()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long, j As Long
Dim delai As Long
Dim cols As Variant
Dim colGauche As String, colDroite As String
' Définir la feuille "TCD"
Set ws = ThisWorkbook.Sheets("TCD")
' Trouver la dernière ligne utilisée dans la colonne N
lastRow = ws.Cells(ws.Rows.Count, "N").End(xlUp).Row
' Colonnes à comparer et à colorer
cols = Array("N", "O", "P", "Q", "R", "S", "T", "U")
' Parcours de toutes les lignes avec données
For i = 2 To lastRow ' Ligne 1 = en-têtes supposées
' Coloration verte si la cellule contient une date ou un "/"
For j = 0 To UBound(cols)
If IsDate(ws.Range(cols(j) & i).Value) Or InStr(ws.Range(cols(j) & i).Value, "/") > 0 Then
ws.Range(cols(j) & i).Interior.Color = RGB(198, 239, 206) ' Vert pastel
Else
ws.Range(cols(j) & i).Interior.ColorIndex = xlNone
End If
Next j
' Comparaison successive entre colonnes
For j = 0 To UBound(cols) - 1
colGauche = cols(j)
colDroite = cols(j + 1)
' Si la cellule de gauche contient une date
If IsDate(ws.Range(colGauche & i).Value) Then
' Si la cellule de droite est vide
If ws.Range(colDroite & i).Value = "" Then
' Calcul du délai en jours entre aujourd'hui et la date de gauche
delai = Date - ws.Range(colGauche & i).Value
' Coloration selon le délai
If delai = 2 Then
ws.Range(colDroite & i).Interior.Color = RGB(255, 229, 153) ' Orange pastel
ElseIf delai >= 3 Then
ws.Range(colDroite & i).Interior.Color = RGB(255, 199, 206) ' Rouge pastel
End If
End If
End If
Next j
Next i
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("N:U")) Is Nothing Then
Application.EnableEvents = False
Call ColorationTCD
Application.EnableEvents = True
End If
End SubBonjour
Merci Joco7915 pour ton retour.
Désolé pour mon retour tardif mais c'est un peu la cours de mon coté en ce moment.
Mais je crois que le fichier nécessite en faite une mise jour. et une reprise de cette macro.
Et je veux bien de l'aide svp.
En faite j'ai une feuille qui se nomme TCD.
Sur cette feuille, dans les colonnes N à U je peux avoir des dates ou des "/" qui viennent s'agrémenter en récupérant des données d'une base de données.
Je voudrais que la cellule dans ces colonne qui contient une de ces deux données passe en vert RGB(198, 239, 206).
Je voudrais ensuite qu'une comparaison soit faite entre par exemple:
N et O et que si N contient une date et que O est vide = comparer la date de N et la date du jour pour que O devienne Orange RGB(255, 229, 153) si la différence est de 2 jours et rouge RGB(255, 199, 206) si on dépasse les trois jours.
cette comparaison doit entre faite entre :
N et O
puis
O et P si P est vide
ou
O et Q et P contient "/"
puis
P si il a une date avec Q
puis
Q et R si R est vide
ou
Q et S si R contient "/"
puis
R si il a une date avec S
puis
S et T
puis
T et U.
Merc pour ton ou votre aide.
Et il faudrait svp que celle ci se fasse automatiquement des qu'une date remonte.
Merci.
Hello
Quelqu'un pour me donner un coup de main svp pour modifier / mettre à jour cette macro ?
Merci beaucoup ;)
Bonjour,
Veuillez fournir un exemple avec votre nouveau TCD et les cellules colorées manuellement en respectant les règles que vous avez énoncées. Ça nous permettra de travailler sur du concret. Merci.
bonjour
Oui c'est vrai que ça sera plus facile pour vous.
Voici le fichier.
Les données dans la feuille Pms100 viennent d'une base de donnée perso.
Ma demande de macro est pour la feuille TCD.
IL faudrait svp, que toutes les colonnes de N à U passe verte RGB(198, 239, 206) des qu'elles ont une date ou un "/".
Ensuite il faudrait que cette date soit comparé à la date du jour quand la cellule de droite est vide pour que cette cellule vide passe orange RGB(255, 229, 153) si la différence est de 2 jours et rouge RGB(255, 199, 206) si on dépasse les trois jours.
Mais quand la cellule de droite contient "/" la comparaison doit "sauter" une colonne et se faire avec la colonne suivante.
Ainsi on compare :
N et O quand O est vide
puis
O et P si P est vide
ou
O et Q et P contient "/"
puis
P si il a une date avec Q
puis
Q et R si R est vide
ou
Q et S si R contient "/"
puis
R si il a une date avec S
puis
S et T
puis
T et U.
Merci infiniment.
Bonjour
Un petit coup de main
Merci.
Bonjour Damien,
Je viens d'ouvrir votre fichier : s'il vous plait coloriez des lignes manuellement pour illustrer votre objectif. Personnellement j'ai vraiment du mal à suivre votre explication :
Vous dites "comparer à la date du jour", donc a priori =AUJOURDHUI(), mais ensuite vous indiquez de comparer les colonnes N et O… Le rapport avec aujourd’hui du coup ? Vous avez d’ailleurs écrit "N et O quand O est vide" ce qui ajoute à ma confusion…
En relisant 20x je crois avoir compris ceci : vous voulez comparer la colonne N à aujourd’hui si la colonne O est vide, pour colorier la cellule en O correspondante.
On a 3 cas de figure :
- O vide : on colorie
- O contient "/" auquel cas on compare (toujours) N à aujourd'hui mais on colorie P…
- O contient une date : on ne fait rien.
Ainsi de suite pour chaque date entre N et U… ?
Mais bon… C'est assez tordu comme explication donc je veux bien une confirmation. Et le coloriage de quelques lignes (pas toutes !) représentatives de vos différents cas de figure aiderait beaucoup.
Merci.
Bonjour
Merci pour ton temps.
Désolé de na pas avoir du donner une explication bien explicite de ma demande, il est vrai que pour moi cela était clair car je connais le fichier mais pas toi.
Les cellules doivent passées en vert des qu'elles ont une date ou un / de façon automatique a chaque modifications.
En effet je souhaite coloré O suite à la comparaison entre N et O quand N a une date. O restera blanc quand la différence entre la date de N et la date du jour est inférieur a 2 jours, elle passera orange a 2 jours de différence, puis rouge passé les 3 jours.
Et ainsi de suite.
Les colonnes susceptibles de contenir des /et donc d'être sauté dans les comparaisons sont P, R et T.
Est ce plus clair pour toi ?
Merci infiniment.
Re,
Ajoutez le code ci-dessous dans un nouveau module, puis lancez la macro ColorizeTCDTable_NtoU. Vous pouvez la lier à un bouton ou une forme.
Notez :
Les cellules doivent passer en vert des qu'elles ont une date ou un / de façon automatique a chaque modifications.
pour cette partie je ne suis pas trop fan, en fait la coloration des cellules n'est pas une étape rapide en VBA, et ajouter des tests ou des appels à la macro risque de ralentir le fichier pour rien. Moi je modifierai les données puis je remettrai à jour tout le tableau : c'est suffisamment rapide pour ne pas être gênant, mais il y a quand même 1 ou 2 secondes de latence qui rendraient fastidieuse la modification du tableau "en temps réel".
EDIT : VOIR MESSAGE SUIVANT
Option Explicit
' Entry point
Public Sub ColorizeTCDTable_NtoU()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("TCD")
Dim startCell As Range
Set startCell = ws.Range("N6")
Dim startRow As Long: startRow = startCell.Row
Dim colN As Long: colN = ws.Columns("N").Column
Dim colU As Long: colU = ws.Columns("U").Column
' Preserve and optimize
Dim prevCalc As XlCalculation: prevCalc = Application.Calculation
Dim prevScreenUpdating As Boolean: prevScreenUpdating = Application.ScreenUpdating
Dim prevEnableEvents As Boolean: prevEnableEvents = Application.EnableEvents
Dim prevStatusBar As Variant: prevStatusBar = Application.StatusBar
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.StatusBar = "Colorizing N:U on sheet 'TCD'..."
On Error GoTo CleanExit
Dim lastRow As Long
lastRow = GetLastUsedRow(ws)
If lastRow < startRow Then GoTo CleanExit
Dim today As Date: today = Date
Dim r As Long
For r = startRow To lastRow
ProcessRow_NtoU ws, r, colN, colU, today
Next r
CleanExit:
Application.Calculation = prevCalc
Application.ScreenUpdating = prevScreenUpdating
Application.EnableEvents = prevEnableEvents
Application.StatusBar = prevStatusBar
End Sub
' Process a single row from column N to U:
' - Dates and "/" are always green
' - The empty cell immediately to the right of a date or "/" may be colored:
' * If the token is a date -> use that date
' * If the token is "/" -> use the nearest date to the left
' Coloring rule on that empty cell:
' res = Today - (reference date)
' res > 3 -> red
' res = 2 -> orange
' else -> no color
' - #N/A: ignore entirely
Public Sub ProcessRow_NtoU(ByVal ws As Worksheet, _
ByVal rowIndex As Long, _
ByVal colN As Long, _
ByVal colU As Long, _
ByVal today As Date)
Dim rngRow As Range
Set rngRow = ws.Range(ws.Cells(rowIndex, colN), ws.Cells(rowIndex, colU))
' Read row values into a 2D 1×N array (always 8 cells here)
Dim data As Variant
data = rngRow.Value ' keeps Variant/Date and Errors
' Clear previous fills over N:U for this row
rngRow.Interior.Pattern = xlNone
Dim rngGreen As Range, rngOrange As Range, rngRed As Range
Dim hasLastDate As Boolean: hasLastDate = False
Dim lastDate As Date
Dim colCount As Long: colCount = UBound(data, 2)
Dim c As Long
For c = 1 To colCount
Dim curVal As Variant
curVal = data(1, c)
' Skip errors entirely
If IsError(curVal) Then
GoTo NextC
End If
Dim tgt As Range
Set tgt = rngRow.Cells(1, c)
' Case 1: Slash => always green; does not update lastDate
If IsSlash(curVal) Then
AddToUnion rngGreen, tgt
' Check the empty cell immediately to the right
If c < colCount Then
Dim rightVal As Variant
rightVal = data(1, c + 1)
If IsBlankLike(rightVal) And hasLastDate Then
Dim diff As Long
diff = CLng(today - lastDate)
If diff >= 3 Then
AddToUnion rngRed, rngRow.Cells(1, c + 1)
ElseIf diff >= 2 Then
AddToUnion rngOrange, rngRow.Cells(1, c + 1)
End If
End If
End If
GoTo NextC
End If
' Case 2: Date (native or text-convertible) => green and update lastDate
Dim d As Date, isDateToken As Boolean
isDateToken = TryGetDate(curVal, d)
If isDateToken Then
AddToUnion rngGreen, tgt
lastDate = d
hasLastDate = True
' Check the empty cell immediately to the right
If c < colCount Then
Dim rightVal2 As Variant
rightVal2 = data(1, c + 1)
If IsBlankLike(rightVal2) Then
Dim diff2 As Long
diff2 = CLng(today - lastDate)
If diff2 >= 3 Then
AddToUnion rngRed, rngRow.Cells(1, c + 1)
ElseIf diff2 >= 2 Then
AddToUnion rngOrange, rngRow.Cells(1, c + 1)
End If
End If
End If
GoTo NextC
End If
' Case 3: Other values (text not "/", numbers not date) => ignore
' No color on current cell; do not update lastDate
NextC:
Next c
' Apply colors once per row
If Not rngGreen Is Nothing Then rngGreen.Interior.Color = 13434828 ' green
If Not rngOrange Is Nothing Then rngOrange.Interior.Color = 49407 ' orange
If Not rngRed Is Nothing Then rngRed.Interior.Color = 255
End Sub
' ---- Helpers --------------------------------------------------------------
' Treat "/" (with surrounding spaces ignored) as the slash token
Private Function IsSlash(ByVal v As Variant) As Boolean
If VarType(v) = vbString Then
IsSlash = (Trim$(CStr(v)) = "/")
Else
IsSlash = False
End If
End Function
' Treat truly empty cells and zero-length strings as blank-like
Private Function IsBlankLike(ByVal v As Variant) As Boolean
If IsError(v) Then
IsBlankLike = False
Exit Function
End If
If IsEmpty(v) Then
IsBlankLike = True
ElseIf VarType(v) = vbString Then
IsBlankLike = (LenB(Trim$(CStr(v))) = 0)
Else
IsBlankLike = False
End If
End Function
' Try to coerce a Variant to a Date; accepts native Date or text convertible to Date
Private Function TryGetDate(ByVal v As Variant, ByRef outDate As Date) As Boolean
On Error GoTo Fail
If IsError(v) Then GoTo Fail
Select Case VarType(v)
Case vbDate
outDate = CDate(v)
TryGetDate = True
Exit Function
Case vbString
Dim s As String
s = Trim$(CStr(v))
If LenB(s) > 0 And IsDate(s) Then
outDate = CDate(s)
TryGetDate = True
Exit Function
End If
Case Else
' Do not treat raw numbers as dates unless Excel already typed them as Date
End Select
Fail:
End Function
' Add a cell to a (possibly Nothing) union range
Private Sub AddToUnion(ByRef target As Range, ByVal addCell As Range)
If target Is Nothing Then
Set target = addCell
Else
Set target = Union(target, addCell)
End If
End Sub
' Last used row on the worksheet
Private Function GetLastUsedRow(ByVal ws As Worksheet) As Long
Dim f As Range
On Error Resume Next
Set f = ws.Cells.Find(What:="*", After:=ws.Cells(1, 1), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
On Error GoTo 0
If f Is Nothing Then
GetLastUsedRow = 0
Else
GetLastUsedRow = f.Row
End If
End FunctionNota : j'ai pensé à un contournement pour la mise à jour automatique, ajoutez le code suivant dans le code de la feuille TCD :
Cela permet de ne recolorier que les cellules de la ou les lignes modifiées (et non tout le tableau)
Option Explicit
' Fires when any cell changes on this sheet
Private Sub Worksheet_Change(ByVal Target As Range)
' Guard: we only react if something in columns N:U changed
Dim rngWatched As Range
Set rngWatched = Me.Columns("N:U")
Dim rngHit As Range
Set rngHit = Intersect(Target, rngWatched)
If rngHit Is Nothing Then Exit Sub
On Error GoTo ExitHandler
' Prevent re-entrancy while we recolor
Application.EnableEvents = False
Dim today As Date: today = Date
Dim colN As Long: colN = Me.Columns("N").Column
Dim colU As Long: colU = Me.Columns("U").Column
' Collect unique row indexes to process (handles multi-cell pastes efficiently)
Dim seen As Object
Set seen = CreateObject("Scripting.Dictionary") ' late-bound, no reference needed
Dim area As Range
For Each area In rngHit.Areas
Dim firstRow As Long: firstRow = area.Row
Dim lastRow As Long: lastRow = area.Row + area.Rows.Count - 1
Dim r As Long
For r = firstRow To lastRow
If Not seen.Exists(r) Then
seen.Add r, True
' Recolor only N:U for the changed row
ProcessRow_NtoU Me, r, colN, colU, today
End If
Next r
Next area
ExitHandler:
Application.EnableEvents = True
End SubBonjour
Merci pour vos retours, je vais tester ça demain.
Bonjour Sabot12617
ça fonctionne bien oui merci ;) mais je comprends pas les formules ne se calculent plus automatiquement, je dois enregistrer mes fichiers excel pour que mes données se mettent a jour.
Ah si c'est bon, je sais pas pourquoi le calcul auto s'était désactivé.
merci Sabot12617, je note mon sujet en résolu.
Ah si c'est bon, je sais pas pourquoi le calcul auto s'était désactivé.
merci Sabot12617, je note mon sujet en résolu.
Si vous voulez éviter ce désagrément, remplacez la macro que je vous ai donnée par celle ci-dessous :
Et désolé pour le désagrément, ça a du planter à mi-chemin d'où le problème que vous avez eu.
Public Sub ColorizeTCDTable_NtoU()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("TCD")
Dim startCell As Range
Set startCell = ws.Range("N6")
Dim startRow As Long: startRow = startCell.Row
Dim colN As Long: colN = ws.Columns("N").Column
Dim colU As Long: colU = ws.Columns("U").Column
' optimization
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo CleanExit
Dim lastRow As Long
lastRow = GetLastUsedRow(ws)
If lastRow < startRow Then GoTo CleanExit
Dim today As Date: today = Date
Dim r As Long
For r = startRow To lastRow
ProcessRow_NtoU ws, r, colN, colU, today
Next r
CleanExit:
Application.ScreenUpdating = prevScreenUpdating
Application.EnableEvents = prevEnableEvents
End SubSi tout fonctionne, n'oubliez pas de clôturer le fil.
Bonne journée
Bonjour Sabot12617
C'est bon, ce fonctionne bien avec l'ancienne.
Par contre est il possible de rendre la maco auto afin que le code couleur s'actualise directement à chaque mise a jour et non à l'appui sur un bouton ?
Merci.
Ps : comment je fais pour clôturer le fil ? (je croyais l'avoir fait).
Bonjour Sabot12617
C'est bon, ce fonctionne bien avec l'ancienne.
Par contre est il possible de rendre la maco auto afin que le code couleur s'actualise directement à chaque mise a jour et non à l'appui sur un bouton ?
Merci.
Ps : comment je fais pour clôturer le fil ? (je croyais l'avoir fait).
Bonjour,
Je vous l'expliquais ici : https://forum.excel-pratique.com/excel/modifier-une-macro-200711#p1257300
Dans l'éditeur VBA, double-cliquez sur la feuille encadrée et collez-y le code de mon message ^^^
