[VBA] Comment trier Aphlanumériquement un Scripting.Dictionary

[Emile63]

Bonjour à tous,

La macro ci-dessous me génère sur une feuille séparée du classeur 5 listes récapitulatives et sans doublons, puisées sur une grande base de de donnée (Feuil1) très répétitives (Certaines colonnes sont numériques, d'autres alphabétiques, et d'autres alphanumériques). Je souhaiterais les trier avant de les afficher mais je bute avec ça.
Si quelqu'un pouvait me donner un coup de main. :-)
De plus, je vois bien que mon code est plutôt chaotique, et pourrait sans doute être affiné. Là encore, je suis ouvert à toutes propositions permettant de gagner en efficacité.

'-------------------------------------
Sub Lister()
' Insertion des différents enregistrements, et tri alphanumérique
Dim MyArray(0 To 5) As String, Col$, x%, y%, i%, Z%

'On Error Resume Next
MyArray(0) = "C"
MyArray(1) = "D"
MyArray(2) = "E"
MyArray(3) = "F"
MyArray(4) = "G"

i = 1 'Boucle sur les 5 colonnes C,D,E,F
x = 0 'Item de la colonne
y = 1 'Colonne cible de la Feuil6 (Avec une col. vide entre-deux)
Z = 3 'N° de la colonne ou il faut compter le NB d'items

For i = 1 To 5
Feuil1.Activate
Col = MyArray(x)
Liste = Feuil1.Range(Col & "5").Address(RowAbsolute:=False, ColumnAbsolute:=False)
Set a = Feuil1.Range(Liste, Cells(Rows.Count, Z).End(xlUp))
Set MonDico = CreateObject("Scripting.Dictionary")
For Each C In a
If Not MonDico.Exists(C.Value) Then MonDico.Add C.Value, C.Value
Next C
Feuil6.Activate
With ActiveSheet
.Cells(1, y).Select
.Cells(1, y).Resize(MonDico.Count, 1) = Application.Transpose(MonDico.keys)
End With
Nom_Entête = ActiveCell.Value
Set MaSelection = ActiveCell.CurrentRegion
MaSelection.Offset(1, 0).Resize(MaSelection.Rows.Count - 1, MaSelection.Columns.Count).Select
Set MaSelection = Selection
MaSelection.Name = Nom_Entête
MonDico.RemoveAll
Set MonDico = Nothing
x = x + 1
y = y + 2
Z = Z + 1
Next
End Sub

'-------------------------------------

Je vous remercie d'avance pour votre aide et conseils. :-)
Cordialement,
Emile

[MichD]

Bonjour,

Adapte le nom des feuilles.

P.S. Décrire ton problème au complet sans tenir compte
de la procédure que tu soumets est une excellente habitude
à prendre.

'---------------------------------------------
Sub MichD()
Dim A As Long, B As Long, DerLig As Long
Dim FD As Worksheet, FS As Worksheet, Rg As Range

Set FD = Worksheets("Feuil1") 'Feuille des données
Set FS = Worksheets("Feuil2") 'Feuille résultat

Application.ScreenUpdating = False
Application.ScreenUpdating = False

'Vide la feuille de résultat
FS.Cells.Clear

With FD
With .Range("C:G")
DerLig = .Find("*", LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For A = 3 To 7 'Colonne C à E
Set Rg = FD.Range(FD.Cells(5, A), FD.Cells(DerLig, A))
Rg.AdvancedFilter xlFilterCopy, , FS.Range("A1").Offset(,
B), True
With FS.Range("A1").Offset(, B).EntireColumn
.Sort Key1:=FS.Range("A1").Offset(, B),
order1:=xlDescending, Header:=xlNo
End With
B = B + 1
Next
End With
End With
Application.ScreenUpdating = True
Application.ScreenUpdating = True

End Sub
'---------------------------------------------




MichD
---------------------------------------------------------------
"Emile63" a écrit dans le message de groupe de discussion :
fa2ea5ab-f036-4c67...@googlegroups.com...

[Emile63]

Bonjour à tous,
Et merci MichD pour ton aide et ta solution.
C'est bien plus simple que le tortueux code que j'avais entrepris :-)
Dans ton exemple, j'ai un petit soucis avec le titre de colonne, qui se mélange avec les données (tri), et d'autre part, je souhaite nommer les plages du même nom que le titre de leur colonne respectives.
D'autre part, est-ce qu'il y a une raison pour que les lignes:
Application.ScreenUpdating
soient doublées?
Encore merci pour ton support, en te souhaitant une très bonne journée.
Emile

[Emile63]

MichD, Je souhaitais encore te demander s'il est possible de ne copier que les valeurs et pas les formats.
Merci pour ta sollicitude,
Cordialement,
Emile

[Fredo P.]

Bonjour Emile

D'autre part, est-ce qu'il y a une raison pour que les lignes:
Application.ScreenUpdating
soient doublées?

§§Oui cela m'intéresse aussi

[MichD]

'-------------------------------------------------

Sub MichD()
Dim A As Long, B As Long, DerLig As Long
Dim FD As Worksheet, FS As Worksheet, Rg As Range

Set FD = Worksheets("Feuil1") 'Feuille des données
Set FS = Worksheets("Feuil2") 'Feuille résultat

Application.ScreenUpdating = False
Application.ScreenUpdating = False

'Vide la feuille de résultat
FS.Cells.Clear

With FD
With .Range("C:G")
DerLig = .Find("*", LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For A = 3 To 7 'Colonne C à E
Set Rg = FD.Range(FD.Cells(5, A), FD.Cells(DerLig, A))
Rg.AdvancedFilter xlFilterCopy, , FS.Range("A1").Offset(,
B), True
With FS.Range("A1")

With .Offset(, B).EntireColumn
.Sort Key1:=FS.Range("A1").Offset(, B), _
order1:=xlAscending, Header:=xlYes
.ClearFormats
End With
.Offset(, B).Resize(DerLig).Name = .Offset(, B).Value

B = B + 1

End With

Next
End With
End With
Application.ScreenUpdating = True
Application.ScreenUpdating = True

End Sub

'------------------------------------------------

MichD
---------------------------------------------------------------

[MichD]

Dans la procédure, corrige cette ligne de code :

.Offset(, B).Resize(DerLig).Name = .Offset(, B).Value

Par

.Offset(, B).Resize(.CurrentRegion.Rows.Count).Name = .Offset(, B).Value

MichD
---------------------------------------------------------------

[MichD]

Dans le cas où dans la plage de la feuille résultat, le nombre de
lignes de chacune des colonnes est différentes...

'---------------------------------------------------------------------
Sub MichD()
Dim A As Long, B As Long, DerLig As Long, Ligne As Long

Dim FD As Worksheet, FS As Worksheet, Rg As Range


Set FD = Worksheets("Feuil1") 'Feuille des données
Set FS = Worksheets("Feuil2") 'Feuille résultat

Application.ScreenUpdating = False
Application.ScreenUpdating = False

'Vide la feuille de résultat
FS.Cells.Clear

With FD
With .Range("C:G")
DerLig = .Find("*", LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For A = 3 To 7 'Colonne C à E
Set Rg = FD.Range(FD.Cells(5, A), FD.Cells(DerLig, A))
Rg.AdvancedFilter xlFilterCopy, , FS.Range("A1").Offset(,
B), True
With FS.Range("A1")
With .Offset(, B)

Ligne = .Cells(Rows.Count, 1).End(xlUp).Row
End With

With .Offset(, B).EntireColumn
.Sort Key1:=FS.Range("A1").Offset(, B), _
order1:=xlAscending, Header:=xlYes
.ClearFormats
End With

.Offset(, B).Resize(Ligne).Name = .Offset(, B).Value

B = B + 1
End With
Next
End With
End With
Application.ScreenUpdating = True
Application.ScreenUpdating = True

End Sub

'---------------------------------------------------------------------




MichD
---------------------------------------------------------------
"MichD" a écrit dans le message de groupe de discussion :
n2kadj$428$1...@speranza.aioe.org...

[Emile63]

Bonsoir à tous,

Merci MichD pour ton aide et pour ta proposition.
Après un petite adaptation, elle fonctionne pile-poils
encore merci et bonne soirée.

Cordialement,
Emile