XL 2016 trier un champ Alphabétiquement

alain160

XLDnaute Nouveau
Bonjour.

J’ai une liste de noms sur 4 colonnes (A1 à D29)

Comment trier alphabétiquement tous ces noms

Le premier nom alphabétique devant se trouver en A1

Le dernier nom alphabétique en D29

Merci par avance
 

alain160

XLDnaute Nouveau
Bonjour Hecatonchire

Merci pour votre réponse mais ça ne répond pas tout à fait à mes souhaits.
Je souhaiterais que la mise en forme du texte soit conservée et j’ai oublié de préciser que la hauteur des colonnes n’est pas identique ….. Ce qui complique le tri.
Pour être plus clair, je joins un tableau récapitulatif.
Je précise qu’une solution avec une macro VBA pourrait me convenir aussi.
Tri champ.jpg

Merci par avance et cordialement
 

job75

XLDnaute Barbatruc
Bonjour alain160, le forum,

Voyez le fichier .xlsm joint el la macro affectée au bouton :
VB:
Sub Trier()
Dim source As Range, dest As Range, c As Range, n&, ncol%, nlig&, j%, i&, nn&
Set source = [A1:D29] 'modifiable
Set dest = [F3] 'modifiable
Application.ScreenUpdating = False
dest.CurrentRegion.Clear 'RAZ
For Each c In source
    If c <> "" Then n = n + 1: c.Copy dest(n)
Next c
If n = 0 Then Exit Sub
dest.Resize(n).Sort dest, xlAscending, Header:=xlNo 'tri
ncol = source.Columns.Count
nlig = Application.RoundUp(n / ncol, 0)
For j = 1 To ncol
    For i = 1 To nlig
        nn = nn + 1
        If j > 1 Then dest(nn).Copy dest(i, j)
        If nn = n Then Exit For
Next i, j
If n > nlig Then dest.Offset(nlig).Resize(n - nlig).Clear 'effacement en bloc
End Sub
A+
 

Pièces jointes

  • Tri.xlsm
    17.8 KB · Affichages: 2
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour le forum,

La macro précédente restitue le tri par colonne, celle-ci le restitue par ligne :
VB:
Sub Trier()
Dim source As Range, dest As Range, c As Range, n&, ncol%, nlig&, nn&
Set source = [A1:D29] 'modifiable
Set dest = [F3] 'modifiable
Application.ScreenUpdating = False
dest.CurrentRegion.Clear 'RAZ
For Each c In source
    If c <> "" Then n = n + 1: c.Copy dest(n)
Next c
If n = 0 Then Exit Sub
dest.Resize(n).Sort dest, xlAscending, Header:=xlNo 'tri
ncol = source.Columns.Count
nlig = Application.RoundUp(n / ncol, 0)
For Each c In dest.Resize(nlig, ncol)
    nn = nn + 1
    dest(nn).Copy c
    If nn = n Then Exit For
Next c
If n > nlig Then dest.Offset(nlig).Resize(n - nlig).Clear 'effacement en bloc
End Sub
A+
 

Pièces jointes

  • Tri.xlsm
    17.9 KB · Affichages: 2
Dernière édition:

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour à tous,

Un autre essai qui conserve aussi les bordures (je n'avais jamais fait attention que le .Sort ne triait pas les bordures avec les cellules du moins sur mon excel).
Le code dans module1 :
VB:
Sub Tri()
Const source = "a3", nbrCol = 4, Cible = "f3"
Dim t, i&, j&, k&, n&, nlig&
   Application.ScreenUpdating = False
   i = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
   t = Range(source).Resize(i, 4)
   ReDim lesVal(1 To UBound(t) * UBound(t, 2)): ReDim lesAdr(1 To UBound(t) * UBound(t, 2))
   For i = 1 To UBound(t): For j = 1 To UBound(t, 2)
      If t(i, j) <> "" Then n = n + 1: lesVal(n) = t(i, j): lesAdr(n) = Range(source)(i, j).Address(0, 0)
   Next j, i
   QuickSort lesVal, 1, n, lesAdr
   nlig = Int(n / nbrCol): If nbrCol * nlig < n Then nlig = nlig + 1
   Range(Range(Cible), Range(Cible).End(xlDown)).Resize(, nbrCol).Clear
   For i = 1 To n
      Range(lesAdr(i)).Copy Range(Cible).Cells(1 + ((i - 1) Mod nlig), 1 + Int((i - 1) / nlig))
   Next i
End Sub

Sub QuickSort(a, gauc, droi, aa)    ' d'après Jacques Boisgontier
'  Voir le code dans le classeur joint...
End Sub
 

Pièces jointes

  • alain160-Tri avec format- v1.xlsm
    19.9 KB · Affichages: 4
Dernière édition:

job75

XLDnaute Barbatruc
Bon pour trier avec les bordures on peut utiliser des formules de liaison :
VB:
Sub Trier()
Dim source As Range, dest As Range, c As Range, n&, ncol%, nlig&, j%, i&, nn&
Set source = [A1:D29] 'modifiable
Set dest = [F3] 'modifiable
Application.ScreenUpdating = False
dest.CurrentRegion.Clear 'RAZ
For Each c In source
    If c <> "" Then n = n + 1: dest(n) = "=" & c.Address 'formule de liaison
Next c
If n = 0 Then Exit Sub
dest.Resize(n).Sort dest, xlAscending, Header:=xlNo 'tri
ncol = source.Columns.Count
nlig = Application.RoundUp(n / ncol, 0)
For j = 1 To ncol
    For i = 1 To nlig
        nn = nn + 1
        Range(Mid(dest(nn).Formula, 2)).Copy dest(i, j)
        If nn = n Then Exit For
Next i, j
If n > nlig Then dest.Offset(nlig).Resize(n - nlig).Clear 'effacement en bloc
End Sub
Chez moi cette macro s'exécute en 0,118 seconde contre 0,185 seconde pour celle du post #5.

Testée dans les mêmes conditions la macro de mapomme s'exécute en 0,106 seconde.
 

Pièces jointes

  • Tri.xlsm
    17.5 KB · Affichages: 2
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
314 863
Messages
2 113 649
Membres
111 930
dernier inscrit
fab_met