Macro de plus en plus longue

Version imprimable

Bonjour,

J'ai crée une macro qui marche très bien, cependant, au bout de plusieurs utilisation elle devient de plus en plus longue et la taille du fichier excel augmente.
J'ai effectué différentes recherches sur internet mais aucune n'a abouti.
Le problème vient peut être de mon code lui-même.
Voici le code en question :

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
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
Option Explicit
 
Sub TriAlpha()
Dim Debut As Range
Dim Lig As Long
Dim DerLig As Long
Dim NbLiGroup As Long
Dim NbLiDerCelGroup  As Long
Dim Groupe As Long
Dim T() As Variant
Dim i As Long
Dim NbLigTabFeuil As Long
Dim NbColTabFeuil As Long
Dim Nom As Variant
Dim Decal As Long
Dim j As Long
Application.CutCopyMode = False
Dim Cible As DataObject
Const LigTablT = 2     ' Nb lignes du tableau T()
 
Application.ScreenUpdating = False
Set Debut = [DebTab]
NbLiGroup = 1                                                                                                                        ' Init. Nb lignes par groupe
NbLiDerCelGroup = Cells(65536, Debut.Column).End(xlUp).MergeArea.Rows.Count                     ' Nb lignes du dernier groupe
DerLig = Cells(65536, Debut.Column).End(xlUp).Row + NbLiDerCelGroup - 1
NbLigTabFeuil = DerLig - Debut.Row
NbColTabFeuil = 14
' --------------- Met en mémoire les caractéristiques du tableau de la feuille dans le tableau T()
i = 0
ReDim T(1 To LigTablT, 1 To 1)                                                                                                 ' Tableau "en long" (a cause du Redim sur dernière dimension)
For Lig = Debut.Row + 1 To DerLig
    Debut.Offset(Lig - Debut.Row, -1).Select
    If Debut.Offset(Lig - Debut.Row, 0).Value = "" Or Debut.Offset(Lig - Debut.Row, 0).Value = "Année" Then                                                                 ' Si la ligne est vide ; la cellule est fusionnée avec
        NbLiGroup = NbLiGroup + 1                                                                                              ' précédente, donc : une ligne de plus
    Else                                                                                                                                    ' Sinon
        NbLiGroup = 1                                                                                                                 ' début de nouveau groupe
        i = i + 1                                                                                                                           ' Ajoute une
        ReDim Preserve T(1 To LigTablT, 1 To i)                                                                             ' colonne au tableau
        T(1, i) = Lig                                                                                                                      ' Mémorise le N° de la ligne de début de groupe
        T(2, i) = Debut.Offset(Lig - Debut.Row, 0).Value                                                                                                                                              ' Mémorise le Nb de ligne fusionnées pour ce groupe (sauf 1er passage)
    End If
Next Lig
 
 
For i = 1 To UBound(T, 1)
    For j = 1 To UBound(T, 2)
        [Q14].Offset(i, j).Select
        ActiveCell.FormulaR1C1 = T(i, j)
    Next j
Next i
 
' --------------- Ajoute une feuille temporaire et la nomme
Dim Feuil
For Each Feuil In ActiveWorkbook.Worksheets
    If Feuil.Name = "AuxiliaireDeTri" Then                                                                                    ' Si une temporaire est éventuellement restée
        Application.DisplayAlerts = False                                                                                      ' on inhibe les alertes
        Worksheets("AuxiliaireDeTri").Delete                                                                                 ' et l'on efface cette feuille (pour éviter une erreur)
    End If
Next Feuil
Sheets.Add                                                                                                                             ' Ajoute la feuille
With ActiveSheet
    .Name = "AuxiliaireDeTri"                                                                                                     ' et la nomme
End With
' --------------- Trie le tableau T()
Call TriVariants2(T, 1, UBound(T, 2), 1, UBound(T, 1), 2)
 
' --------------- En fonction du tableau T() trié, copie chaque groupe de la feuille de départ dans la feuille "Tri" Pour garder les formats
With Worksheets("Analyses")
    Decal = 1
    For Groupe = 1 To UBound(T, 2)
        .Range(.Cells(T(1, Groupe), .[DebTab].Column), (.Cells(T(1, Groupe) + _
        2, .[DebTab].Column + NbColTabFeuil - 1))).Copy                                           ' copie la plage
        With Worksheets("AuxiliaireDeTri")
 
            .Range("A1").Offset(Decal, 0).Select
            Decal = Decal + 3
 
            ActiveSheet.Paste
        End With
        Set Cible = New DataObject
        Cible.SetText ""
        Cible.PutInClipboard
 
Set Cible = Nothing
    Next Groupe
End With
 
' --------------- Copie le tableau complet de la feuille "Tri" dans la feuille de départ pour garder les formats
With Worksheets("Analyses")
    .Range(.[DebTab].Offset(1, 0), .[DebTab].Offset(NbLigTabFeuil, _
    NbColTabFeuil - 1)).MergeCells = False                                                                                  ' Défusionne la plage initiale
    .Range(.[DebTab].Offset(1, 0), .[DebTab].Offset(NbLigTabFeuil, _
    NbColTabFeuil - 1)).Interior.ColorIndex = xlNone                                                                      ' Supprime la couleur du fond
End With
Worksheets("AuxiliaireDeTri").Activate
Range([A2], [A2].Offset(NbLigTabFeuil - 1, NbColTabFeuil - 1)).Copy                                             ' Met le tableau de la feuille temporaire dans le tampon
Worksheets("Analyses").Activate
Range([DebTab].Offset(1, 0), [DebTab].Offset(NbLigTabFeuil, NbColTabFeuil - 1)).Select                 ' Met le tampon dans le tableau initial
ActiveSheet.Paste
[A2].Select
Set Cible = New DataObject
Cible.SetText ""
Cible.PutInClipboard
 
Set Cible = Nothing
' --------------- Efface la feuille temporaire
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("AuxiliaireDeTri").Delete
Application.ScreenUpdating = True
 
 
End Sub
 
' ================= Procédure de tri QuickSort adaptée ici à un tableau horizontal multilignes =========================
Sub TriVariants2(T As Variant, IndBasCol As Long, IndHautCol As Long, IndBasLig As Long, IndHautLig As Long, IndLignTriee As Long)
' Paramètres :
' Tabl = tableau de Variants à trier
' IndBasLig = indice bas des lignes du tableau (= Lbound(Tabl,1))
' IndHautLig = indice haut des lignes du tableau (= Ubound(Tabl,1))
' IndBasCol = indice bas des colonnes du tableau (= Lbound(Tabl,2))
' IndHautCol = indice haut des colonnes du tableau (= Ubound(Tabl,2))
' IndLignTriee = indice de la ligne sur laquelle s'effectue le tri
Application.CutCopyMode = False
Dim j As Long
Dim i As Long
 
For j = 1 To UBound(T, 2)
    For i = 1 To UBound(T, 1)
        [Z1].Offset(j - 1, i - 1).Select
        ActiveCell.FormulaR1C1 = T(i, j)
    Next i
Next j
 
ActiveWorkbook.Worksheets("AuxiliaireDeTri").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("AuxiliaireDeTri").Sort.SortFields.Add Key:=Range("AA1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("AuxiliaireDeTri").Sort
    .SetRange Range("AA1:Z500")
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
 
For j = 1 To UBound(T, 2)
    For i = 1 To UBound(T, 1)
        T(i, j) = [Z1].Offset(j - 1, i - 1).Value
    Next i
Next j
 
End Sub

Merci et bonne journée !

Bonjour,

Dans un premier temps, élimine les Select qui ne servent qu'à ralentir le processus
Ex:
Code:

1 2 3 4 5 6 For i = 1 To UBound(T, 1) For j = 1 To UBound(T, 2) [Q14].Offset(i, j).Select ActiveCell.FormulaR1C1 = T(i, j) Next j Next i
équivaut à
Code:

1 2 3 4 5 For i = 1 To UBound(T, 1) For j = 1 To UBound(T, 2) [Q14].Offset(i, j).FormulaR1C1 = T(i, j) Next j Next i
Aussi, le DataObject semble servir à vider le presse-papier seulement.
Tu pourrais l'éviter et utiliser
Application.CutCopyMode = False si nécessaire.

Merci pour cette réponse, j'ai effectué les modifications en question et voici le code obtenu :

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
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
Option Explicit
 
Sub TriAlpha()
Dim Debut As Range
Dim Lig As Long
Dim DerLig As Long
Dim NbLiGroup As Long
Dim NbLiDerCelGroup  As Long
Dim Groupe As Long
Dim T() As Variant
Dim i As Long
Dim NbLigTabFeuil As Long
Dim NbColTabFeuil As Long
Dim Nom As Variant
Dim Decal As Long
Dim j As Long
Application.CutCopyMode = False
 
Const LigTablT = 2     ' Nb lignes du tableau T()
 
Application.ScreenUpdating = False
Set Debut = [DebTab]
NbLiGroup = 1                                                                                                                        ' Init. Nb lignes par groupe
NbLiDerCelGroup = Cells(65536, Debut.Column).End(xlUp).MergeArea.Rows.Count                     ' Nb lignes du dernier groupe
DerLig = Cells(65536, Debut.Column).End(xlUp).Row + NbLiDerCelGroup - 1
NbLigTabFeuil = DerLig - Debut.Row
NbColTabFeuil = 14
' --------------- Met en mémoire les caractéristiques du tableau de la feuille dans le tableau T()
i = 0
ReDim T(1 To LigTablT, 1 To 1)                                                                                                 ' Tableau "en long" (a cause du Redim sur dernière dimension)
For Lig = Debut.Row + 1 To DerLig
    If Debut.Offset(Lig - Debut.Row, 0).Value = "" Or Debut.Offset(Lig - Debut.Row, 0).Value = "Année" Then                                                                 ' Si la ligne est vide ; la cellule est fusionnée avec
        NbLiGroup = NbLiGroup + 1                                                                                              ' précédente, donc : une ligne de plus
    Else                                                                                                                                    ' Sinon
        NbLiGroup = 1                                                                                                                 ' début de nouveau groupe
        i = i + 1                                                                                                                           ' Ajoute une
        ReDim Preserve T(1 To LigTablT, 1 To i)                                                                             ' colonne au tableau
        T(1, i) = Lig                                                                                                                      ' Mémorise le N° de la ligne de début de groupe
        T(2, i) = Debut.Offset(Lig - Debut.Row, 0).Value                                                                                                                                              ' Mémorise le Nb de ligne fusionnées pour ce groupe (sauf 1er passage)
    End If
Next Lig
 
 
For i = 1 To UBound(T, 1)
    For j = 1 To UBound(T, 2)
        [Q14].Offset(i, j).FormulaR1C1 = T(i, j)
    Next j
Next i
 
' --------------- Ajoute une feuille temporaire et la nomme
Dim Feuil
For Each Feuil In ActiveWorkbook.Worksheets
    If Feuil.Name = "AuxiliaireDeTri" Then                                                                                    ' Si une temporaire est éventuellement restée
        Application.DisplayAlerts = False                                                                                      ' on inhibe les alertes
        Worksheets("AuxiliaireDeTri").Delete                                                                                 ' et l'on efface cette feuille (pour éviter une erreur)
    End If
Next Feuil
Sheets.Add                                                                                                                             ' Ajoute la feuille
With ActiveSheet
    .Name = "AuxiliaireDeTri"                                                                                                     ' et la nomme
End With
' --------------- Trie le tableau T()
Call TriVariants2(T, 1, UBound(T, 2), 1, UBound(T, 1), 2)
 
' --------------- En fonction du tableau T() trié, copie chaque groupe de la feuille de départ dans la feuille "Tri" Pour garder les formats
With Worksheets("Analyses")
    Decal = 1
    For Groupe = 1 To UBound(T, 2)
        .Range(.Cells(T(1, Groupe), .[DebTab].Column), (.Cells(T(1, Groupe) + _
        2, .[DebTab].Column + NbColTabFeuil - 1))).Copy                                           ' copie la plage
        With Worksheets("AuxiliaireDeTri")
 
 
            ActiveSheet.Range("A1").Offset(Decal, 0).PasteSpecial
            Decal = Decal + 3
 
        End With
    Next Groupe
End With
 
' --------------- Copie le tableau complet de la feuille "Tri" dans la feuille de départ pour garder les formats
With Worksheets("Analyses")
    .Range(.[DebTab].Offset(1, 0), .[DebTab].Offset(NbLigTabFeuil, _
    NbColTabFeuil - 1)).MergeCells = False                                                                                  ' Défusionne la plage initiale
    .Range(.[DebTab].Offset(1, 0), .[DebTab].Offset(NbLigTabFeuil, _
    NbColTabFeuil - 1)).Interior.ColorIndex = xlNone                                                                      ' Supprime la couleur du fond
End With
Worksheets("AuxiliaireDeTri").Activate
Range([A2], [A2].Offset(NbLigTabFeuil - 1, NbColTabFeuil - 1)).Copy                                             ' Met le tableau de la feuille temporaire dans le tampon
Worksheets("Analyses").Activate
ActiveSheet.Range([DebTab].Offset(1, 0), [DebTab].Offset(NbLigTabFeuil, NbColTabFeuil - 1)).PasteSpecial             ' Met le tampon dans le tableau initial
' --------------- Efface la feuille temporaire
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("AuxiliaireDeTri").Delete
Application.ScreenUpdating = True
 
 
End Sub
 
' ================= Procédure de tri QuickSort adaptée ici à un tableau horizontal multilignes =========================
Sub TriVariants2(T As Variant, IndBasCol As Long, IndHautCol As Long, IndBasLig As Long, IndHautLig As Long, IndLignTriee As Long)
' Paramètres :
' Tabl = tableau de Variants à trier
' IndBasLig = indice bas des lignes du tableau (= Lbound(Tabl,1))
' IndHautLig = indice haut des lignes du tableau (= Ubound(Tabl,1))
' IndBasCol = indice bas des colonnes du tableau (= Lbound(Tabl,2))
' IndHautCol = indice haut des colonnes du tableau (= Ubound(Tabl,2))
' IndLignTriee = indice de la ligne sur laquelle s'effectue le tri
Application.CutCopyMode = False
Dim j As Long
Dim i As Long
 
For j = 1 To UBound(T, 2)
    For i = 1 To UBound(T, 1)
        [Z1].Offset(j - 1, i - 1).FormulaR1C1 = T(i, j)
    Next i
Next j
 
ActiveWorkbook.Worksheets("AuxiliaireDeTri").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("AuxiliaireDeTri").Sort.SortFields.Add Key:=Range("AA1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("AuxiliaireDeTri").Sort
    .SetRange Range("AA1:Z500")
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
 
For j = 1 To UBound(T, 2)
    For i = 1 To UBound(T, 1)
        T(i, j) = [Z1].Offset(j - 1, i - 1).Value
    Next i
Next j
 
End Sub

Même si le résultat est mieux le problème persiste toujours. Après environ 5 applications de cette macro la taille du fichier double et le temps d'exécution est au moins multiplié par 10.

13/07/2016, 11h44
parmi
Je vois que tu supprimes la feuille "AuxiliaireDeTri" et la recrée tout de suite après...
Pourquoi ne pas simplement la vider ?

Lorsque tu copies tes données, il n'est pas nécessaire de sélectionner les feuilles en questions, surtout si tu copies tel quel (valeurs, formats,...), et non seulement les valeurs, disons.
Par exemple, ceci copie la plage A1:Z100 d'une feuille à l'autre

Code:

Sheets("Feuil1").Range("A1:Z100").copy Sheets("Feuil2").Range("A1")

Tu pourrais aussi essayer de mettre le mode de calcul en manuel au début et le remettre en automatique à la fin
Code:

1 2 3 Application.Calculation = xlCalculationManual 'Traitement Application.Calculation = xlCalculationAutomatic

Merci, je vais laisser la feuille auxiliaire présente et je la viderai juste.
Cependant lorsque j'essaie d'appliquer la suite, je me heurte à une erreur que je n'arrive pas à résoudre.

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
Option Explicit
 
Sub TriAnneeDec()
Application.Calculation = xlCalculationManual
Dim Debut As Range
Dim Lig As Long
Dim DerLig As Long
Dim NbLiGroup As Long
Dim NbLiDerCelGroup  As Long
Dim Groupe As Long
Dim T() As Variant
Dim I As Long
Dim NbLigTabFeuil As Long
Dim NbColTabFeuil As Long
Dim Nom As Variant
Dim Decal As Long
Application.CutCopyMode = False
Dim j As Long
 
Const LigTablT = 2     ' Nb lignes du tableau T()
 
Application.ScreenUpdating = False
Set Debut = [DebTab].Offset(0, 2 - 1)
 
NbLiGroup = 1                                                                                                                        ' Init. Nb lignes par groupe
NbLiDerCelGroup = Cells(65536, Debut.Column).End(xlUp).MergeArea.Rows.Count                     ' Nb lignes du dernier groupe
DerLig = Cells(65536, Debut.Column).End(xlUp).Row + NbLiDerCelGroup - 1
NbLigTabFeuil = DerLig - Debut.Row
NbColTabFeuil = 14
' --------------- Met en mémoire les caractéristiques du tableau de la feuille dans le tableau T()
I = 0
ReDim T(1 To LigTablT, 1 To 1)                                                                                                 ' Tableau "en long" (a cause du Redim sur dernière dimension)
For Lig = Debut.Row + 1 To DerLig
    If Debut.Offset(Lig - Debut.Row, 0).Value = "" Or Debut.Offset(Lig - Debut.Row, 0).Value = "Année" Then                                                                 ' Si la ligne est vide ; la cellule est fusionnée avec
        NbLiGroup = NbLiGroup + 1                                                                                              ' précédente, donc : une ligne de plus
    Else                                                                                                                                    ' Sinon
        NbLiGroup = 1                                                                                                                 ' début de nouveau groupe
        I = I + 1                                                                                                                           ' Ajoute une
        ReDim Preserve T(1 To LigTablT, 1 To I)                                                                             ' colonne au tableau
        T(1, I) = Lig                                                                                                                      ' Mémorise le N° de la ligne de début de groupe
        T(2, I) = Debut.Offset(Lig - Debut.Row, 0).Value                                                                                                                                              ' Mémorise le Nb de ligne fusionnées pour ce groupe (sauf 1er passage)
    End If
Next Lig
 
 
' --------------- Ajoute une feuille temporaire et la nomme
Dim Feuil
Worksheets("AuxiliaireDeTri").Range("A1").ClearContents
 
' --------------- Trie le tableau T()
Call TriVariants(T, 1, UBound(T, 2), 1, UBound(T, 1), 2)
 
' --------------- En fonction du tableau T() trié, copie chaque groupe de la feuille de départ dans la feuille "Tri" Pour garder les formats
 
Decal = 1
For Groupe = 1 To UBound(T, 2)
 
    Worksheets("Analyses").Range(Worksheets("Analyses").Cells(T(1, Groupe), Worksheets("Analyses").[DebTab].Column), (Worksheets("Analyses").Cells(T(1, Groupe) + _
    2, Worksheets("Analyses").[DebTab].Column + NbColTabFeuil - 1))).Copy Worksheets("AuxiliaireDeTri").Range("A1").Offset(Decal, 0)
    Decal = Decal + 3
 
 
Next Groupe
 
 
 
End Sub

J'ai modifier le début du code comme ceci mais une erreur remonte à cette ligne ci :

Code:

Worksheets("AuxiliaireDeTri").Range("A1").ClearContents

Erreur 9, l'indice n'appartient pas à la sélection.
Je ne comprend pas vraiment l'erreur étant donné que je précise sur quelle feuille je travaille. J'ai également essayé de préciser le book sur lequel je travail mais sans succès.

Merci

13/07/2016, 17h23
parmi

Tu veux effacer seulement la cellule A1 ?
Si tu veux tout effacer, essaie

Code:

Worksheets("AuxiliaireDeTri").Cells.ClearContents

Autrement, il m'arrive d'avoir ce problème et je dois sélectionner la feuille pour pouvoir agir sur celle-ci.
Le problème semble aléatoire...(?)
18/07/2016, 10h26
Doomro

Très bien, merci.
En effet, cette erreur a l'air assez aléatoire j'ai résolu le problème en copiant le code dans un nouveau fichier sans effectuer aucune modification.

Toujours dans l'objectif d'optimiser ce programme, j'ai une erreur à cette ligne là quand je veux enlever les selects :

Code:

Worksheets("AuxiliaireDeTri").Range([A2], [A2].Offset(NbLigTabFeuil - 1, NbColTabFeuil - 1)).Copy Worksheets("Analyses").Range([DebTab].Offset(1, 0), [DebTab].Offset(NbLigTabFeuil, NbColTabFeuil - 1))

J'ai suivi la synthase que tu m'avais conseillée et j'ai l'erreur 1004, erreur définie par l'application ou pas l'object.

Merci.

J'ai finalement réussi à régler le problème, voici le 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
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
Option Explicit
 
Sub TriAnneeDec()
Application.Calculation = xlCalculationManual
Dim Debut As Range
Dim Lig As Long
Dim DerLig As Long
Dim NbLiGroup As Long
Dim NbLiDerCelGroup  As Long
Dim Groupe As Long
Dim T() As Variant
Dim I As Long
Dim NbLigTabFeuil As Long
Dim NbColTabFeuil As Long
Dim Nom As Variant
Dim Decal As Long
Application.CutCopyMode = False
Dim j As Integer
 
Dim NbCol As Integer
Dim NbRow As Integer
Dim CopyRange As Range
Dim PasteRange As Range
 
Const LigTablT = 2     ' Nb lignes du tableau T()
 
Application.ScreenUpdating = False
Set Debut = [DebTab].Offset(0, 2 - 1)
NbLiGroup = 1                                                                                                                        ' Init. Nb lignes par groupe
NbLiDerCelGroup = Cells(65536, Debut.Column).End(xlUp).MergeArea.Rows.Count                     ' Nb lignes du dernier groupe
DerLig = Cells(65536, Debut.Column).End(xlUp).Row + NbLiDerCelGroup - 1
NbLigTabFeuil = DerLig - Debut.Row
NbColTabFeuil = 14
 
' --------------- Met en mémoire les caractéristiques du tableau de la feuille dans le tableau T()
I = 0
ReDim T(1 To LigTablT, 1 To 1)                                                                                                 ' Tableau "en long" (a cause du Redim sur dernière dimension)
For Lig = Debut.Row + 1 To DerLig
    If Debut.Offset(Lig - Debut.Row, 0).Value = "" Or Debut.Offset(Lig - Debut.Row, 0).Value = "Année" Then                                                                 ' Si la ligne est vide ; la cellule est fusionnée avec
        NbLiGroup = NbLiGroup + 1                                                                                              ' précédente, donc : une ligne de plus
    Else                                                                                                                                    ' Sinon
        NbLiGroup = 1                                                                                                                 ' début de nouveau groupe
        I = I + 1                                                                                                                           ' Ajoute une
        ReDim Preserve T(1 To LigTablT, 1 To I)                                                                             ' colonne au tableau
        T(1, I) = Lig                                                                                                                      ' Mémorise le N° de la ligne de début de groupe
        T(2, I) = Debut.Offset(Lig - Debut.Row, 0).Value                                                                                                                                              ' Mémorise le Nb de ligne fusionnées pour ce groupe (sauf 1er passage)
    End If
Next Lig
 
 
' --------------- Trie le tableau T()
Call TriVariants(T, 1, UBound(T, 2), 1, UBound(T, 1), 2)
 
' --------------- En fonction du tableau T() trié, copie chaque groupe de la feuille de départ dans la feuille "Tri" Pour garder les formats
Decal = 1
For Groupe = 1 To UBound(T, 2)
    Worksheets("Analyses").Range(Cells(T(1, Groupe) - 1, [DebTab].Column), (Cells(T(1, Groupe) + 1, [DebTab].Column + NbColTabFeuil - 1))).Copy _
    Worksheets("AuxiliaireDeTri").Range("A1").Offset(Decal, 0)
    Decal = Decal + 3
Next Groupe
 
' --------------- Copie le tableau complet de la feuille "Tri" dans la feuille de départ pour garder les formats
 
 
 
With Worksheets("Analyses")
    .Range(.[DebTab].Offset(1, 0), .[DebTab].Offset(NbLigTabFeuil, _
    NbColTabFeuil - 1)).MergeCells = False                                                                                  ' Défusionne la plage initiale
    .Range(.[DebTab].Offset(1, 0), .[DebTab].Offset(NbLigTabFeuil, _
    NbColTabFeuil - 1)).Interior.ColorIndex = xlNone                                                                      ' Supprime la couleur du fond
End With
 
 
 
Worksheets("AuxiliaireDeTri").Range(Worksheets("AuxiliaireDeTri").[A2], Worksheets("AuxiliaireDeTri").[A2].Offset(NbLigTabFeuil - 1, NbColTabFeuil - 1)).Copy _
Destination:=Worksheets("Analyses").Range(Worksheets("Analyses").[DebTab].Offset(1, 0), Worksheets("Analyses").[DebTab].Offset(NbLigTabFeuil, NbColTabFeuil - 1))
 
 
 
' --------------- Efface la feuille temporaire
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("AuxiliaireDeTri").Cells.ClearContents
Application.ScreenUpdating = True
 
Application.Calculation = xlCalculationAutomatic
 
End Sub
 
 
 
' ================= Procédure de tri QuickSort adaptée ici à un tableau horizontal multilignes =========================
Sub TriVariants(Tabl As Variant, IndBasCol As Long, IndHautCol As Long, IndBasLig As Long, IndHautLig As Long, IndLignTriee As Long)
' Paramètres :
' Tabl = tableau de Variants à trier
' IndBasLig = indice bas des lignes du tableau (= Lbound(Tabl,1))
' IndHautLig = indice haut des lignes du tableau (= Ubound(Tabl,1))
' IndBasCol = indice bas des colonnes du tableau (= Lbound(Tabl,2))
' IndHautCol = indice haut des colonnes du tableau (= Ubound(Tabl,2))
' IndLignTriee = indice de la ligne sur laquelle s'effectue le tri
Application.Calculation = xlCalculationManual
Application.CutCopyMode = False
 
Dim j As Long
Dim I As Long
Dim Pivot As Variant
Dim TmpSwap As Variant
Dim TmpBas As Long
Dim TmpHaut As Long
Dim Ligne As Long
 
TmpBas = IndBasCol
TmpHaut = IndHautCol
Pivot = Tabl(IndLignTriee, (IndBasCol + IndHautCol) \ 2)
While (TmpBas <= TmpHaut)
    While (Tabl(IndLignTriee, TmpBas) < Pivot And TmpBas < IndHautCol)
    TmpBas = TmpBas + 1
    Wend
    While (Pivot < Tabl(IndLignTriee, TmpHaut) And TmpHaut > IndBasCol)
    TmpHaut = TmpHaut - 1
    Wend
    If (TmpBas <= TmpHaut) Then
        For Ligne = IndBasLig To IndHautLig
            TmpSwap = Tabl(Ligne, TmpBas)
            Tabl(Ligne, TmpBas) = Tabl(Ligne, TmpHaut)
            Tabl(Ligne, TmpHaut) = TmpSwap
        Next Ligne
        TmpBas = TmpBas + 1
        TmpHaut = TmpHaut - 1
    End If
Wend
' --------------- Appel récursif
If (IndBasCol < TmpHaut) Then Call TriVariants(Tabl, IndBasCol, TmpHaut, IndBasLig, IndHautLig, IndLignTriee)
If (TmpBas < IndHautCol) Then Call TriVariants(Tabl, TmpBas, IndHautCol, IndBasLig, IndHautLig, IndLignTriee)
 
 
Application.Calculation = xlCalculationAutomatic
 
 
End Sub

Cependant, le problème initial subsiste toujours, après 4 appels de la macro la taille du fichier a augmenté de 80Ko ...
Le temps d’exécution passe de instantanée à plus de 10s.