Sub test2()
Dim Rg As Range, C As Range, T As Variant
Dim Trouve As Range, A As Long, Adr As String
Dim B As Long, D As Integer, X As Integer
Dim Sh As Worksheet, Col As Integer
Application.ScreenUpdating = False
On Error Resume Next
'Ajout d'une feuille contenant le résultat
'---Suppression de la feuille Résultat si elle existe
Application.DisplayAlerts = False
Worksheets("Résultat").Delete
Application.DisplayAlerts = True
'---Création de la feuille résultat
Set Sh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
Sh.Name = "Résultat"
'---Détermine la plage source où se trouve le tableau à transposer
With Worksheets("Données")
Set Rg = .Range("A3:A" & .Range("A65536").End(xlUp).Row)
End With
'---Création d'un objet "dictionary" contenant une liste unique
' de chacun des items de la liste
Set dic = CreateObject("Scripting.Dictionary")
'Création de la liste
For Each C In Rg
If Not dic.Exists(C.Value) Then
dic.Add C.Value, C.Value
End If
Next
'Copie les données du dictionary dans une variable Tableau
T = dic.items
'Tri par ordre croissant le contenu du tableau
Quick_Sort T, LBound(T), UBound(T)
'Copie dans la première colonne de la feuille Résultat la liste
'des items du tableau T
Sh.Range("A1").Resize(UBound(T) + 1) = Application.Transpose(T)
'Pour chaque élément du tableau
For A = LBound(T) To UBound(T)
With Rg.Offset(-1, 0).Resize(Rg.Rows.Count + 1, 1)
'recherche la location de la valeur dans la liste de la
'feuille des données
Set Trouve = .Find(What:=T(A), LookIn:=xlValues, _
LooKAt:=xlWhole, Searchdirection:=xlNext, _
MatchCase:=False)
'Lorsque trouvé,
If Not Trouve Is Nothing Then
'Notation de l'adresse
Adr = Trouve.Address
'Boucle tant que toutes les données du tableau des données
'n'ont pas été copiées vers la plage destination
Do
With Worksheets(Trouve.Parent.Name)
X = .Cells(Trouve.Row, .Cells.Columns.Count).End(xlToLeft).Column
End With
Col = X - Trouve.Column
Trouve.Offset(, 1).Resize(1, Col).Copy Sh.Range("B1").Offset(B, D)
D = D + Col
Set Trouve = .FindNext(Trouve)
'sort de la boucle lorsque la recheche (Find) revient
'à la première cellule trouvée
Loop Until Trouve.Address = Adr
B = B + 1: D = 0
End If
End With
Next
'met une bordure autant des cellules de la première colonne
'de la feuille destination
For X = 7 To 12
With Sh.Range("A1").Resize(UBound(T) + 1).Borders(X)
.LineStyle = xlContinuous
.Weight = xlThin
End With
Next
'Ajuste la largeur des colonnes de la feuille Résultat
Sh.Range("A1").CurrentRegion.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
'------------------------------------------------
Sub Quick_Sort(ByRef SortArray As Variant, ByVal First As Long, ByVal Last As Long)
Dim Low As Long, High As Long
Dim Temp As Variant, List_Separator As Variant
Low = First
High = Last
List_Separator = SortArray((First + Last) / 2)
Do
Do While (SortArray(Low) < List_Separator)
Low = Low + 1
Loop
Do While (SortArray(High) > List_Separator)
High = High - 1
Loop
If (Low <= High) Then
Temp = SortArray(Low)
SortArray(Low) = SortArray(High)
SortArray(High) = Temp
Low = Low + 1
High = High - 1
End If
Loop While (Low <= High)
If (First < High) Then Quick_Sort SortArray, First, High
If (Low < Last) Then Quick_Sort SortArray, Low, Last
End Sub
