Optimisation / alternative macro

Version imprimable

Bonjour,

Ci-après une macro qui fonctionne. J'aimerai votre avis sur l'existence d'une alternative - faire la même chose mais avec une méthode / approche différente - qui serait plus académique ou plus courte ou "plus mieux" ...
J'ai mis en forme des bouts de codes à l'aide de l'enregistreur de macro et des discussions du forum, et donc suis preneur de tuyaux ... merci par avance pour votre retour :D

Code:

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
 Sub Macro1()
Application.ScreenUpdating = False
ActiveSheet.Name = "R"
Cells.Select
    With Selection
    .HorizontalAlignment = xlGeneral
    End With
    With Selection
    .HorizontalAlignment = xlCenter
    End With
 
Dim Plage As Range
Dim C As Range
Dim Row As Range
Dim LastLig As Long
Dim i As Long
 
 
'mise en forme des colonnes 
 
With Sheets("R")
.Rows("1:1").RowHeight = 48
.Columns("A:A").ColumnWidth = 5.86
.Columns("E:E").ColumnWidth = 25.86
.Columns("F:F").ColumnWidth = 19.14
.Columns("G:G").ColumnWidth = 11.29
.Columns("H:H").ColumnWidth = 11.57
.Columns("K:K").ColumnWidth = 5.29
.Columns("S:S").ColumnWidth = 33.57
End With
 
'mise sous forme de tableau 
 
With Sheets("R")
.ListObjects.Add(xlSrcRange, [A2].CurrentRegion, xlYes).Name = "Tableau1"
.ListObjects("Tableau1").TableStyle = "TableStyleMedium6"
'.ListObjects("Tableau1").Sort.SortFields.Clear
'.ListObjects("Tableau1").Sort.SortFields.Add Key:=Range("Tableau1[[#All],[Age]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlNormal
End With
 
'niveau de rémunération  
With Sheets("R")
LastLig = Range("E" & Rows.Count).End(xlUp).Row
 
For i = LastLig To 2 Step -1
 
If .Range("E" & i).Text Like "" Then .Range("E" & i).Interior.ColorIndex = 3
 
Next i
End With
 
'présence de prix
With Sheets("R")
 
LastLig = Range("G" & Rows.Count).End(xlUp).Row
 
For i = LastLig To 2 Step -1
 
If .Range("G" & i).Text = "NON" Then .Range("G" & i).Interior.ColorIndex = 3
Next i
End With
 
'disponibilité 
With Sheets("R")
 
LastLig = Range("H" & Rows.Count).End(xlUp).Row
 
For i = LastLig To 2 Step -1
If .Range("H" & i).Text Like "*pas dispo*" Then .Range("H" & i).Interior.ColorIndex = 3        
Next i
End With
 
'prospection 
With Sheets("R")
 
Set Plage = .Range("J2:J" & .Range("J" & .Rows.Count).End(xlUp).Row)
 
For Each C In Plage
 
If C.Value = "ETAB" Then
If ((C.Offset(0, 1).Value Like "*A jour*") Or (C.Offset(0, 1).Value Like "*A voir *") Or (C.Offset(0, 1).Value Like "*Relance*")) Then
C.Offset(0, 1).Interior.Color = vbRed
End If
End If
 
Next C
Set Plage = Nothing
 
End With
 
'âge apprenti inférieur à 26 ans 
 
With Sheets("R")
 
Set Plage = .Range("R2:R" & .Range("R" & .Rows.Count).End(xlUp).Row)
 
For Each C In Plage
If C.Value < 26 Then C.Interior.Color = vbCyan
 
Next C
Set Plage = Nothing
 
End With
 
 
'Plan d’actions vide
 
With Sheets("R")
 
Set Plage = .Range("S2:S" & .Range("S" & .Rows.Count).End(xlUp).Row)
 
For Each C In Plage
If C.Value = "" Then C.Interior.Color = vbCyan
 
Next C
Set Plage = Nothing
 
End With
Application.ScreenUpdating = True
End Sub

Bonjour,

Ci-dessous une proposition de remise en forme, pour faciliter la lecture des contributeurs :

Code:

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
Sub Macro1()
    Dim Plage As Range, C As Range
    Dim LastLig As Long, i As Long
 
    Application.ScreenUpdating = False
    With ActiveSheet
        .Name = "R"
        .Cells.HorizontalAlignment = xlCenter
 
'Mise en forme des colonnes 
        .Rows("1:1").RowHeight = 48
        .Columns("A:A").ColumnWidth = 5.86
        .Columns("E:E").ColumnWidth = 25.86
        .Columns("F:F").ColumnWidth = 19.14
        .Columns("G:G").ColumnWidth = 11.29
        .Columns("H:H").ColumnWidth = 11.57
        .Columns("K:K").ColumnWidth = 5.29
        .Columns("S:S").ColumnWidth = 33.57
 
'Mise sous forme de tableau
        With .ListObjects.Add(xlSrcRange, .Cells(1, 2).CurrentRegion, xlYes)
            .Name = "Tableau1"
            .TableStyle = "TableStyleMedium6"
            '.Sort.SortFields.Clear
            '.Sort.SortFields.Add Key:=Range("Tableau1[[#All],[Age]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlNormal
        End With
 
'Niveau de rémunération
        LastLig = .Cells(.Rows.Count, 5).End(xlUp).Row
        For i = LastLig To 2 Step -1
            If .Cells(i, 5).Text Like "" Then _
                .Cells(i, 5).Interior.ColorIndex = 3
        Next i
 
'Présence de prix
        LastLig = .Cells(.Rows.Count, 7).End(xlUp).Row
        For i = LastLig To 2 Step -1
            If .Cells(i, 7).Text = "NON" Then _
                .Cells(i, 7).Interior.ColorIndex = 3
        Next i
 
'Disponibilité 
        LastLig = .Cells(.Rows.Count, 8).End(xlUp).Row
        For i = LastLig To 2 Step -1
            If .Cells(i, 8).Text Like "*pas dispo*" Then _
                .Cells(i, 8).Interior.ColorIndex = 3        
        Next i
 
'Prospection
        Set Plage = .Range(.Cells(2, 10), .Cells(.Rows.Count, 10).End(xlUp))
        For Each C In Plage
            If C.Value = "ETAB" Then
                If ((C.Offset(0, 1).Value Like "*A jour*") Or (C.Offset(0, 1).Value Like "*A voir *") Or (C.Offset(0, 1).Value Like "*Relance*")) Then
                    C.Offset(0, 1).Interior.Color = vbRed
                End If
            End If
        Next C
 
'Âge apprenti inférieur à 26 ans
        Set Plage = .Range(.Cells(2, 18), .Cells(.Rows.Count, 18).End(xlUp))
        For Each C In Plage
            If C.Value < 26 Then _
                C.Interior.Color = vbCyan
        Next C
 
'Plan d’actions vide
        Set Plage = .Range(.Cells(2, 19), .Cells(.Rows.Count, 19).End(xlUp))
        For Each C In Plage
            If C.Value = "" Then _
                C.Interior.Color = vbCyan
        Next C
    End With
    Application.ScreenUpdating = True
End Sub

Et quelques remarques :

Vous définissez un tableau structuré. Il semblerait préférable de l'utiliser pour faire les mises en forme. En particulier, recalculer le numéro de la dernière ligne autant de fois paraît superflu.
La mise en couleur d'une plage est plus efficace en utilisant une Mise en Forme Conditionnelle. Cela n'est toutefois applicable que si vous souhaitez que cette mise en couleur soit dynamique. S'il est important que votre mise en couleur ne soit pas modifiée lorsque vous modifiez manuellement les données du tableau, alors une boucle reste le bon outil.
Le caractère "*" utilisé dans les chaînes de caractères servant de 2ème opérande à l'instruction Like est interprété comme une wildcard. Vérifiez que c'est bien le comportement attendu.

Cdt

27/10/2021, 12h36
midge

Merci pour les remarques et modifications :ccool:, la boucle correspond effectivement à l'objectif du tableau. Le like produit l'effet attendu .
Lorsque vous indiquez que le recalcul répété de la dernière ligne est superflu, pourrait-on procéder autrement ? Les recherches sont sur des colonnes différentes excepté pour 2 colonnes adjacentes ...
27/10/2021, 14h31
Ben_L

Dans la mesure où vous définissez un tableau structuré sur la région courante associée à la cellule A2, on peut supposer que la dernière ligne pertinente, quelle que soit la colonne, est la dernière ligne de ce tableau structuré.
Mais tout cela dépend de vos données.

Si cette méthode est acceptable pour vous, vous pouvez accéder au nombre de lignes de votre tableau par les méthodes/propriétés :

Code:

.ListRows.Count

Vérifiez bien le comportement obtenu, j'avoue ne pas encore bien maîtriser les tableaux structurés. En particulier, les lignes d'entêtes seront elles prises en compte, etc.