Optimiser une macro de mise en forme d'un Tableau

Version imprimable

J'ai un code qui me permet de mettre en forme un tableau sur Excel,
le problème avec mon code c'est que ça me prend une minute pour avoir un résultat. Mon objectif est d'optimiser ce code.

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
Sub Macro()
Dim FL1 As Worksheet
Dim i As Integer
Set FL1 = Worksheets("sheet1")
'Mise en forme sheet sheet1
FL1.Activate
For i = 3 To 6000
If FL1.Cells(i, 1) = "Metier" Then
 
Cells(i, 1).Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection.Interior
        .ColorIndex = 44
        .Pattern = xlSolid
    End With
    End If
    Next i
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Set FL1 = Nothing
 
End Sub

Bonsoir Mouncefdi, le forum

Sans avoir testé ton code essaies déjà ces corrections :

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
Sub Macro()
Dim FL1 As Worksheet
Dim i As Integer
Set FL1 = Worksheets("sheet1")
'Mise en forme sheet sheet1
FL1.Activate
For i = 3 To 6000
If FL1.Cells(i, 1) = "Metier" Then
With Range(Cells(i, 1), Cells(i, 1).End(xlToRight))..Interior
        .ColorIndex = 44
        .Pattern = xlSolid
    End With
    End If
Next i
     Range(Cells(i, 1), , Cells(i, 1), .End(xlDown)).Borders(xlDiagonalDown).LineStyle = xlNone
    Range(Cells(i, 1), , Cells(i, 1), .End(xlDown))..Borders(xlDiagonalUp).LineStyle = xlNone
    With Range(Cells(i, 1), , Cells(i, 1), .End(xlDown)).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Range(Cells(i, 1), , Cells(i, 1), .End(xlDown)).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Range(Cells(i, 1), , Cells(i, 1), .End(xlDown)).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Range(Cells(i, 1), , Cells(i, 1), .End(xlDown)).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Range(Cells(i, 1), , Cells(i, 1), .End(xlDown)).Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Range(Cells(i, 1), , Cells(i, 1), .End(xlDown)).Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Set FL1 = Nothing
 
End Sub

ça elimine déjà les select, mais il y a mieux, je ne suis pas encore pret et je n'ai pas vérifié ton code

a+

10/04/2009, 12h19
mouncefdi

Merci pour les corrections, le problème est résolu merci