[XL-2010] Amélioré performance macro

Bonjour,

Dans mon fichier Excel j'ai deux tableau nommée dans une même feuille.
Quand je rentre quelque chose dans une colonne du tableau mais que la cellule n'est pas dans le tableau je souhaite que le tableau se redimensionne tout seul.
j'analyse aussi le contenu d'une colonne afin de coloré les case en différente couleur suivant un critère.

Jusque la tout fonctionne biens cependant ce processus est assez long et fais ralentir l'utilisateur dans sa saisie.
j'ai donc dans ma feuille un macro :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Not Intersect(Target, [C7:R1048576]) Is Nothing Then
    If lanceunefois = 0 Then
        Call redimTablProd
        Call colorRef
    End If
    lanceunefois = 0
End If
If Not Intersect(Target, [AC7:AR1048576]) Is Nothing Then
    If lanceunefois = 0 Then Call redimTablPres
End If
lanceunefois = 0
Application.ScreenUpdating = True
End Sub

cette macro se lance quand les case du la plage de cellule sont modifier.
dans un module j'ai donc

Code:

Public lanceunefois As Integer

la macro qui permet de coloré les cases:

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
Public Sub colorRef()
Dim NoLigDate As Integer
Dim NoLigProduit As Integer
Dim NoLigRef As Integer
Dim Ref As Range
Dim Prod As Range
Dim i As Integer
Dim j As Integer
Dim noblig As Integer
 
 
 
 
NoLigProduit = Application.WorksheetFunction.CountA([T34:T1048576])
 
For Each k In Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "N", "O", "P", "Q", "R")
    down = Range(k & "6").End(xlDown).Row
    up = Range(k & "1048576").End(xlUp).Row
    If down = up And Range(k & up).Value <> "" Then temp = up
    If down <> up And Range(k & up).Value <> "" Then temp = up
    If down <> up And Range(k & down).Value <> "" And Range(k & up).Value = "" Then temp = down
 
 If noblig <= temp Then noblig = temp
Next k
 
 
If noblig < 7 Then
Range("D7").Interior.ColorIndex = xlNone
Range("D" & noblig + 1, "D1048576").Interior.ColorIndex = xlNone
GoTo finmacro
End If
 
For Each Ref In Range("D7", "D" & noblig)
 
    If Ref.Value <> "" Then
        i = 0
        j = 0
        For Each Prod In Range("T34", "T" & NoLigProduit + 33)
            If InStr(1, UCase(Ref.Value), UCase(Prod.Value)) <> 0 Then i = i + 1
            If InStr(1, UCase(Prod.Value), UCase(Ref.Value)) <> 0 Then j = j + 1
        Next Prod
        If j = 1 And i = 0 Then Ref.Interior.ColorIndex = 3
        If j = 1 And i = 1 Then Ref.Interior.ColorIndex = xlNone
        If j = 0 And i = 1 Then Ref.Interior.ColorIndex = xlNone
        If j = 0 And i = 0 Then Ref.Interior.ColorIndex = 45
        If j > 1 Then Ref.Interior.ColorIndex = 3
        If i > 1 Then Ref.Interior.ColorIndex = 3
    Else
        Ref.Interior.ColorIndex = 6
    End If
Next Ref
 
Range("D" & noblig + 1, "D1048576").Interior.ColorIndex = xlNone
 
finmacro:
End Sub

et la macro qui permet de modifier le tableau.

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
Public Sub redimTablProd()
Dim noblig As Integer
Dim temp As Integer
Dim down As String
Dim up As String
lanceunefois = 1
ThisWorkbook.ActiveSheet.ListObjects("Tableau_Ref_Prod_" & ActiveSheet.Name).Resize Range("$C$6:$R$" & 7)
lanceunefois = 1
noblig = 7
For Each i In Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "N", "O", "P", "Q", "R")
down = Range(i & "6").End(xlDown).Row
up = Range(i & "1048576").End(xlUp).Row
    If Range(i & up).Value <> "" Then temp = up
    If noblig <= temp Then noblig = temp
Next i
ThisWorkbook.ActiveSheet.ListObjects("Tableau_Ref_Prod_" & ActiveSheet.Name).Resize Range("$C$6:$R$" & noblig)
End Sub
 
 
Public Sub redimTablPres()
 
Dim noblig As Integer
Dim temp As Integer
Dim down As String
Dim up As String
noblig = 7
lanceunefois = 1
ThisWorkbook.ActiveSheet.ListObjects("Tableau_Ref_Pres_" & ActiveSheet.Name).Resize Range("$AC$6:$AR$" & 7)
lanceunefois = 1
For Each i In Array("AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AN", "AO", "AP", "AQ", "AR")
down = Range(i & "6").End(xlDown).Row
up = Range(i & "1048576").End(xlUp).Row
    If down = up And Range(i & up).Value <> "" Then temp = up
    If down <> up And Range(i & up).Value <> "" Then temp = up
    If down <> up And Range(i & down).Value <> "" And Range(i & up).Value = "" Then temp = down
 
 If noblig <= temp Then noblig = temp
Next i
If noblig = 6 Then ThisWorkbook.ActiveSheet.ListObjects("Tableau_Ref_Pres_" & ActiveSheet.Name).Resize Range("$AC$6:$AR$" & noblig + 1)
If noblig <> 6 Then ThisWorkbook.ActiveSheet.ListObjects("Tableau_Ref_Pres_" & ActiveSheet.Name).Resize Range("$AC$6:$AR$" & noblig)
End Sub

cependant a la ligne :

Code:

ThisWorkbook.ActiveSheet.ListObjects("Tableau_Ref_Pres_" & ActiveSheet.Name).Resize Range("$AC$6:$AR$" & 7)

la première macro de lancement sur la feuil se relance. j'ai donc évité de tout relancer en ajoutant une variable public "lanceunefois".
Cela a amélioré nettement les performance de mes macros.

je sais qu'il est possible de la rendre encore plus compact en regroupant la macro redimTablPres et redimTablProd mais cela me convient.

J'ai donc un ensemble de macro qui s'effectue correctement et qui répondes à mes attentes, cependant je trouve que le temps de réponse est trop long , elle met trop de temps à s'effectuer.
Est-il possible d'amélioré les performance de la macro ? si oui pouvez vous m'indiquer une manière de procéder afin que je modifie mon code ?
cordialement,
Passepartout007