[XL-2010] Reduire le temps d'excécution de ma macro

Chers experts,
Je suis novice en VBA et j'ai du m'inscrire ce matin vous crier à l'aider espérant trouver une solution à mon problème.
Voila, j'ai adapté une macro qui me permet de mettre à jour des shapes que j'ai crée dans une feuille Excel. La macro fonctionne bien mais le temps d’exécution est très long (11 min).
J'ai lu à travers les forums qu'il faut réduire les procédures "select" et utiliser la commande screenUpdating que j'ai mis dans mon code. Mais hélas, le temps d'exécution est réduis mais je suis toujours à 10 min.
Quelqu'un pourrait-il m'aider en m'indiquant une commande quelque conque ou voir ce qui rend mon code si lent?
Je le joins à toute fins utile

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
Sub Colorie_Cellules(numZone As Integer, zoneclor As String)
Range("Zone" & numZone).Select
Application.ScreenUpdating = False
For Each cell In Selection
VAT = cell.Offset(0, 1)
For Each cell2 In Range(zoneclor)
    If VAT >= cell2.Value And VAT < cell2.Offset(0, 1).Value Then cell.Offset(0, 1).Interior.Color = cell2.Offset(0, 2).Interior.Color: GoTo suite
Next
suite:
Next
Application.ScreenUpdating = True
End Sub
 
Sub Colorie_District(numZone As Integer)
 On Error Resume Next
Range("Zone" & numZone).Select
Application.ScreenUpdating = False
For Each cell In Selection
cell.Select
Couleur = ActiveCell.Offset(0, 1).Interior.Color
ActiveSheet.Shapes.Range(Array(ActiveCell.Text & Format(numZone, "00"))).Select
 
With Selection.ShapeRange(1).Fill
        .Visible = msoTrue
        .ForeColor.RGB = Couleur
        .Transparency = 0
        .Solid
    End With
Next
Application.ScreenUpdating = True
[A1].Select
End Sub
 
Sub Efface_District(numZone As Integer, zoneclor As String)
 On Error Resume Next
Range("Zone" & numZone).Select
Application.ScreenUpdating = False
Dim n As String
 
For Each cell In Selection
cell.Select
Couleur = ActiveCell.Offset(0, 1).Interior.Color
 
ActiveSheet.Shapes.Range(Array(ActiveCell.Text & Format(numZone, "00"))).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = ""
 
 
With Selection.ShapeRange(1).Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 255, 255)
        .Transparency = 0
        .Solid
    End With
 
 
Next
 
For Each cell In Range("Zone" & numZone)
cell.Offset(0, 1).Interior.Color = xlNone
Next
Application.ScreenUpdating = True
[M1].Select
 
End Sub
Sub mise_a_jour ()
Call Efface_District(1, "ZoneCoul1")
Call Colorie_Cellules(1, "ZoneCoul1")
Call Colorie_District(1)
Call Efface_District(2, "ZoneCoul2")
Call Colorie_Cellules(2, "ZoneCoul2")
Call Colorie_District(2)
Call Efface_District(3, "ZoneCoul3")
Call Colorie_Cellules(3, "ZoneCoul3")
Call Colorie_District(3)
End Sub