Discussion :

[naozumi8]

Bonjour,

J'ai modifié mon code

Voici mon code Actuel :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
Sub ComparerEtCopierDescriptif()
    Dim wsGlobal As Worksheet
    Dim wsOld As Worksheet
    Dim lastRowGlobal As Long
    Dim lastRowOld As Long
    Dim numRowGlobal As Range
    Dim numRowOld As Range
    Dim DescriptifRangeOld As Range
    Dim DescriptifCell As Range
    Dim matchCell As Range
	Dim lastRow As Long
    Dim cell As Range
 
    ' Renommer la feuille active en "Global"
ActiveSheet.Name = "Global"
 
' AnnulationRetourLigneAuto Macro
'
 
'
    Cells.Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
 
' LargeurColonne Macro
'
 
'
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("C:C").Select
    Selection.ColumnWidth = 57#
    Columns("F:F").Select
    Selection.ColumnWidth = 8#
    Columns("I:I").Select
    Selection.ColumnWidth = 12#
    Columns("H:H").Select
    Selection.ColumnWidth = 12#
 
 
    ' Remplacez "Global" par le nom de la feuille de calcul qui contient les données exportées
    Set ws = ThisWorkbook.Sheets("Global")
 
    ' Applique un style bleu clair comme tableau
    If ActiveCell.Row <> lastRow Then
            ws.ListObjects.Add(xlSrcRange, ws.UsedRange, , xlYes).TableStyle = "TableStyleLight13"
    End If
 
    ' Date limite : aujourd'hui moins 7 jours
    dateLimite = Date - 7
 
    ' Trouver la dernière ligne avec des données dans la colonne E
    lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
 
   ' Parcourir chaque cellule de la colonne "Mis à jour" sur la feuille "Global"
    For Each cell In ws.Range("E2:E" & lastRow)
        If IsDate(cell.Value) Then
            ' Vérifier si la date est aujourd'hui ou dans les 7 jours précédents
            If DateValue(cell.Value) >= dateLimite And DateValue(cell.Value) <= Date Then
                ' Remplir la ligne entière de Rose
                ws.Range("A" & cell.Row & ":L" & cell.Row).Interior.Color = RGB(248, 203, 173) ' Rose
            End If
        End If
    Next cell
 
' Définir la valeur de la cellule F1 sur "Action"
    ActiveSheet.Range("F1").Select
        ActiveCell.Value = Replace(ActiveCell.Value, "Work notes list", "Action")
 
' Définir la valeur de la cellule G1 sur "Auteur"
    ActiveSheet.Range("G1").Select
        ActiveCell.Value = Replace(ActiveCell.Value, "Date d'échéance", "Auteur")
 
' Définir la valeur de la cellule H1 sur "Titre"
    ActiveSheet.Range("H1").Select
        ActiveCell.Value = Replace(ActiveCell.Value, "Ref Thales (SRM)", "Titre")
 
' Définir la valeur de la cellule J1 sur "Descriptif"
    ActiveSheet.Range("J1").Select
        ActiveCell.Value = Replace(ActiveCell.Value, "En attente de", "Descriptif")
 
          ' Remplacez "Global" et "OLD" par les noms de vos feuilles de calcul
    Set wsGlobal = ThisWorkbook.Sheets("Global")
    Set wsOld = ThisWorkbook.Sheets("OLD")
 
    ' Trouver la dernière ligne avec des données dans la colonne "Numéro" de la feuille "Global"
    lastRowGlobal = wsGlobal.Cells(wsGlobal.Rows.Count, "A").End(xlUp).Row
 
    ' Trouver la dernière ligne avec des données dans la colonne "Numéro" de la feuille "OLD"
    lastRowOld = wsOld.Cells(wsOld.Rows.Count, "A").End(xlUp).Row
 
    ' Définir la plage de données dans les colonnes "Numéro" et "Descriptif" de la feuille "Global"
    Set numRowGlobal = wsGlobal.Range("A2:A" & lastRowGlobal)
    Set DescriptifRangeGlobal = wsGlobal.Range("J2:J" & lastRowGlobal)
 
    ' Définir la plage de données dans les colonnes "Numéro" et "Descriptif" de la feuille "OLD"
    Set numRowOld = wsOld.Range("A2:A" & lastRowOld)
    Set DescriptifRangeOld = wsOld.Range("J2:J" & lastRowOld)
 
    ' Parcourir chaque cellule de la colonne "Numéro" de la feuille "Global"
    For Each numCell In numRowGlobal
        ' Recherche de la correspondance dans la feuille "OLD"
        Set matchCell = numRowOld.Find(numCell.Value, LookIn:=xlValues)
 
        ' Si une correspondance est trouvée, colorier la ligne en Orange
        If Not matchCell Is Nothing Then
            wsGlobal.Range("A" & numCell.Row & ":L" & numCell.Row).Interior.Color = RGB(255, 192, 0) ' Orange
 
            ' Copier les Descriptif de la feuille "OLD" vers la feuille "Global"
            Set DescriptifCell = DescriptifRangeOld.Cells(matchCell.Row - DescriptifRangeOld.Row + 1)
            numCell.Offset(0, 9).Value = DescriptifCell.Value ' Copier dans la colonne "Descriptif" de la feuille "Global"
        End If
    Next numCell
 
    Application.ScreenUpdating = False ' Désactiver la mise à jour de l'écran pour accélérer le processus
 
    ' Créer un dictionnaire pour stocker les Genres
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
 
    ' Activer la première cellule de la colonne contenant les Genres (colonne K)
    ws.Activate
    ws.Range("K2").Select
 
 
    ' Boucle à travers chaque cellule dans la colonne des Genres 
    Do Until IsEmpty(ActiveCell)
        ' Obtenir le nom du Genre
        Genre = ActiveCell.Value
 
 
 
    ' Si le Genre n'est pas déjà dans le dictionnaire, le stocker
        If Not dict.Exists(Genre) Then
            dict.Add Genre, 0
        End If
 
        ' Aller à la prochaine cellule dans la colonne des Genres
        ActiveCell.Offset(1, 0).Select
    Loop
 
    ' Boucle à travers les Genres stockés dans le dictionnaire
    For Each Genre In dict.Keys
        ' Créer une nouvelle feuille de calcul avec le nom du Genre
        ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = Genre
        Set newWs = ThisWorkbook.Sheets(Genre)
 
        ' Copier la ligne d'en-tête depuis la feuille "Global"
        ws.Rows(1).Copy Destination:=newWs.Rows(1)
 
        ' Réinitialiser la variable lastRow
        lastRow = 0
 
        ' Activer la première cellule de la colonne contenant les Genres (colonne K)
        ws.Activate
        ws.Range("K2").Select
 
        ' Boucle à travers chaque cellule dans la colonne des Genres
        Do Until IsEmpty(ActiveCell)
            ' Obtenir le nom du Genre 
            If ActiveCell.Value = Genre Then
                ' Vérifier si la ligne n'a pas déjà été copiée
                If ActiveCell.Row <> lastRow Then
                    ' Copier la ligne de données dans la feuille de calcul du Genre 
                    ws.Rows(ActiveCell.Row).Copy Destination:=newWs.Cells(newWs.Cells(newWs.Rows.Count, "A").End(xlUp).Row + 1, 1)
                    ' Mettre à jour la variable lastRow
                    lastRow = ActiveCell.Row
                End If
            End If
 
            ' Aller à la prochaine cellule dans la colonne des Genres
            ActiveCell.Offset(1, 0).Select
        Loop
 
' Appliquer le style au tableau sur la feuille en cours
        newWs.ListObjects.Add(xlSrcRange, newWs.UsedRange, , xlYes).TableStyle = "TableStyleLight13"
 
' LargeurColonne Macro pour chaque feuille
'
 
'
   newWs.Cells.EntireColumn.AutoFit
    newWs.Columns("C:C").ColumnWidth = 57
    newWs.Columns("F:F").ColumnWidth = 8
    newWs.Columns("I:I").ColumnWidth = 12
    newWs.Columns("H:H").ColumnWidth = 12
 
    Next Genre
 
'  Supprimer la feuille "OLD" à la fin
  ThisWorkbook.Sheets("OLD").Delete ' Supprimer la feuille "OLD"
 
 
 
    Application.ScreenUpdating = True ' Réactiver la mise à jour de l'écran
 
End Sub

Je voudrais que
Si il est vérifié récent ET que Numéro est présent dans OLD alors que la ligne soit en rouge (si vérifié récent et non présent dans Old : rose, si non vérifié récent et présent dans OLD : orange)

De plus que sur chaque feuille,5 lignes en dessous du tableau, en colonne E mettre une cellule en couleur RGB(255, 192, 0) avec en colonne F sur la même ligne, mettre : "Déjà lu".
la ligne en dessous en colonne E la couleur RGB(248, 203, 173) avec en colonne F sur la même ligne, mettre : "Vérifié Récent"
la ligne en dessous en colonne E la couleur RGB(180, 198, 231) avec en colonne F sur la même ligne, mettre : "En attente"
la ligne en dessous en colonne E la couleur RGB(169, 208, 142) avec en colonne F sur la même ligne, mettre : "Abandonné"

(en gros, faire une sorte de tableau avec association de couleur et correspondance afin de savoir rapidement en allant en base des tableau a quoi correspondent les couleurs)

Merci beaucoup pour vos aides

Notamment celui de franc qui a bien fonctionné

[Franc]

Bonjour, c'est parce que tu utilises .entirerow.

Essaie comme ceci, adapte si besoin:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 ' Remplir toute la ligne en orange
  ws.Range("A" & cell.Row & ":J" & cell.Row).Interior.Color = RGB(255, 165, 0) ' Orange

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
' Si une correspondance est trouvée, colorier toute la ligne en bleu clair
If Not matchCell Is Nothing Then
    wsGlobal.Range("A" & numCell.Row & ":J" & numCell.Row).Interior.Color = RGB(173, 216, 230) ' Bleu clair

[Franc]

Teste ceci, je t'ai fait une macro indépendante pour ne pas surcharger ta macro existante, de plus ce sera plus facile si tu veux modifier ou ajouter des couleurs.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
Sub MiseEnFormeFeuilles()
    Dim ws As Worksheet
    Dim wsOld As Worksheet
    Dim lastRowGlobal As Long
    Dim lastRowOld As Long
    Dim numCell As Range
    Dim matchCell As Range
    Dim couleurCell As Range
    Dim lastRow As Long
 
    Set ws = ThisWorkbook.Sheets("Global")
    Set wsOld = ThisWorkbook.Sheets("OLD")
 
    lastRowGlobal = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastRowOld = wsOld.Cells(wsOld.Rows.Count, "A").End(xlUp).Row
 
    ' Parcourir chaque cellule de la colonne "Numéro" de la feuille "Global"
    For Each numCell In ws.Range("A2:A" & lastRowGlobal)
        ' Recherche de la correspondance dans la feuille "OLD"
        Set matchCell = wsOld.Range("A2:A" & lastRowOld).Find(numCell.Value, LookIn:=xlValues)
 
        ' Si une correspondance est trouvée
        If Not matchCell Is Nothing Then
            ' Si vérifié récent (colonne E) et présent dans OLD, colorier la ligne en rouge
            If ws.Cells(numCell.Row, "E").Value = "Vérifié Récent" Then
                ws.Range("A" & numCell.Row & ":L" & numCell.Row).Interior.Color = RGB(255, 0, 0) ' Rouge
            ' Si non vérifié récent (colonne E) et présent dans OLD, colorier la ligne en orange
            ElseIf ws.Cells(numCell.Row, "E").Value <> "Vérifié Récent" Then
                ws.Range("A" & numCell.Row & ":L" & numCell.Row).Interior.Color = RGB(255, 192, 0) ' Orange
            End If
        ' Si non vérifié récent (colonne E) et non présent dans OLD, colorier la ligne en rose
        ElseIf ws.Cells(numCell.Row, "E").Value <> "Vérifié Récent" Then
            ws.Range("A" & numCell.Row & ":L" & numCell.Row).Interior.Color = RGB(248, 203, 173) ' Rose
        End If
    Next numCell
 
    ' Ajouter le tableau des couleurs en bas de chaque feuille
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "OLD" Then ' Ne pas appliquer sur la feuille "OLD"
            ' Trouver la première cellule vide 5 lignes en dessous du tableau
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            Set couleurCell = ws.Cells(lastRow + 5, 5)
 
            ' Déjà lu
            couleurCell.Interior.Color = RGB(255, 192, 0) ' Orange
            couleurCell.Offset(0, 1).Value = "Déjà lu"
 
            ' Vérifié Récent
            couleurCell.Offset(1, 0).Interior.Color = RGB(248, 203, 173) ' Rose
            couleurCell.Offset(1, 1).Value = "Vérifié Récent"
 
            ' En attente
            couleurCell.Offset(2, 0).Interior.Color = RGB(180, 198, 231) ' Bleu clair
            couleurCell.Offset(2, 1).Value = "En attente"
 
            ' Abandonné
            couleurCell.Offset(3, 0).Interior.Color = RGB(169, 208, 142) ' Vert clair
            couleurCell.Offset(3, 1).Value = "Abandonné"
        End If
    Next ws
End Sub

[naozumi8]

Ah, je me suis mal expliqué,

Quand j'indiquai si il est vérifié récent cela voulait dire : si la date est aujourd'hui ou dans les 7 jours précédents

[Franc]

Comme ceci alors:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
Sub MiseEnFormeFeuilles()
    Dim ws As Worksheet
    Dim wsOld As Worksheet
    Dim lastRowGlobal As Long
    Dim lastRowOld As Long
    Dim numCell As Range
    Dim matchCell As Range
    Dim couleurCell As Range
    Dim lastRow As Long
    Dim dateLimite As Date
 
    Set ws = ThisWorkbook.Sheets("Global")
    Set wsOld = ThisWorkbook.Sheets("OLD")
 
    lastRowGlobal = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastRowOld = wsOld.Cells(wsOld.Rows.Count, "A").End(xlUp).Row
 
    ' Date limite : aujourd'hui moins 7 jours
    dateLimite = Date - 7
 
    ' Parcourir chaque cellule de la colonne "Numéro" de la feuille "Global"
    For Each numCell In ws.Range("A2:A" & lastRowGlobal)
        ' Recherche de la correspondance dans la feuille "OLD"
        Set matchCell = wsOld.Range("A2:A" & lastRowOld).Find(numCell.Value, LookIn:=xlValues)
 
        ' Si une correspondance est trouvée
        If Not matchCell Is Nothing Then
            ' Vérifier si la date est aujourd'hui ou dans les 7 jours précédents
            If IsDate(ws.Cells(numCell.Row, "E").Value) Then
                If DateValue(ws.Cells(numCell.Row, "E").Value) >= dateLimite And DateValue(ws.Cells(numCell.Row, "E").Value) <= Date Then
                    ' Si vérifié récent et présent dans OLD, colorier la ligne en rouge
                    ws.Range("A" & numCell.Row & ":L" & numCell.Row).Interior.Color = RGB(255, 0, 0) ' Rouge
                Else
                    ' Si non vérifié récent et présent dans OLD, colorier la ligne en orange
                    ws.Range("A" & numCell.Row & ":L" & numCell.Row).Interior.Color = RGB(255, 192, 0) ' Orange
                End If
            End If
        Else
            ' Si non vérifié récent (colonne E) et non présent dans OLD, colorier la ligne en rose
            If IsDate(ws.Cells(numCell.Row, "E").Value) Then
                If DateValue(ws.Cells(numCell.Row, "E").Value) >= dateLimite And DateValue(ws.Cells(numCell.Row, "E").Value) <= Date Then
                    ws.Range("A" & numCell.Row & ":L" & numCell.Row).Interior.Color = RGB(248, 203, 173) ' Rose
                End If
            End If
        End If
    Next numCell
 
    ' Ajouter le tableau des couleurs en bas de chaque feuille
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "OLD" Then ' Ne pas appliquer sur la feuille "OLD"
            ' Trouver la première cellule vide 5 lignes en dessous du tableau
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            Set couleurCell = ws.Cells(lastRow + 5, 5)
 
            ' Déjà lu
            couleurCell.Interior.Color = RGB(255, 192, 0) ' Orange
            couleurCell.Offset(0, 1).Value = "Déjà lu"
 
            ' Vérifié Récent
            couleurCell.Offset(1, 0).Interior.Color = RGB(248, 203, 173) ' Rose
            couleurCell.Offset(1, 1).Value = "Vérifié Récent"
 
            ' En attente
            couleurCell.Offset(2, 0).Interior.Color = RGB(180, 198, 231) ' Bleu clair
            couleurCell.Offset(2, 1).Value = "En attente"
 
            ' Abandonné
            couleurCell.Offset(3, 0).Interior.Color = RGB(169, 208, 142) ' Vert clair
            couleurCell.Offset(3, 1).Value = "Abandonné"
        End If
    Next ws
End Sub