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 |
Macro de plus en plus longue
Répondre avec citation
Partager