Les tris et sous-totaux

Accueil

TriSimple
TriMultiCrit
TriPerso
SousTot
Fonction Sous.Total()
Tri VBA
Tri 2 Critères
Tri Zones Vides
Tri numérique de valeurs alphanumériques
Tri dynamique
Tri par groupe
Tri de fiches
Tri Gras
Tri sur la couleur de fond
Tri cadres
Tri avec images
Tri par clic sur le titre
Tri mots avec apostrophes
Tri multi-feuilles
Tri des onglets
Tri quick-sort
Tri matriciel
Fonction liste triée
Liste triée Multi-Zones

Tri simple

  • Cliquer dans la colonne de tri (B2 pour trier par service)
  • Icône A-Z

Tri multi-critères

  • Cliquer dans la base (A1 par exemple)
  • Données/Trier

Tri personnalisé

On veut trier par service dans l'ordre DG,Etudes,Marketing,Ventes,Fabric:

  • Créer une liste personalisée (DG,Etudes,Marketing,Ventes,Fabric) avec la commande Outils/Options/Liste perso
  • Cliquer dans la base
  • Données/Trier
  • Choisir Service
  • Options
  • Choisir la liste personnalisée

Création liste personnalisée

Options de tri

Sous totaux

On veut obtenir la moyenne des salaires par service.

  • Trier par service
  • Données/sous-total

Fonction Sous.Total(NoFonction;champ1;Champ2, ..)

Donne un total dans une liste filtrée.

No Fonction

Lignes masquées

Opération

1

101

MOYENNE

2

102

NB

3

103

NBVAL

4

104

MAX

5

105

MIN

6

106

PRODUIT

7

107

ECARTYPE

8

108

ECARTYPEP

9

109

SOMME

10

110

VAR

Sur cet exemple, nous calculons des sous-totaux par poste et un total général.

Tri en VBA

champ.Sort Key1:=cellule, Order1:=xlAscending/XlDescending,
    Key2:=cellule, Order2:=xlAscending/XlDescending,
    Key3:=cellule, Order3:=xlAscending/XlDescending,
    Header:=xlGuess

Tri 1 critère

Sub tri()
   Sheets("BD").[A1].Sort key1:=Sheets("BD").[A2], Order1:=xlAscending, Header:=xlGuess
End Sub

Tri 2 critères

Sub tri2()
   Sheets("BD2").[A1].Sort key1:=Sheets("BD2").[A2], Order1:=xlAscending, _
       key2:=Sheets("BD2").[B2], Order2:=xlAscending, Header:=xlGuess
End Sub

Tri vertical

Tri Vertical

Tri avec zones incomplétes

On veut trier par département.

TriVides
TriVides2

Sub Tri()
  Set début = Range("A1")
  ncol = début.CurrentRegion.Columns.Count
  début.Offset(0, ncol).EntireColumn.Insert Shift:=xlToRight
  début.CurrentRegion.Resize(, 1).Copy
  début.Offset(0, ncol).Select
  ActiveSheet.Paste
  Selection.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
  Selection.Value = Selection.Value
  début.Sort Key1:=Cells(1, ncol + 1), Order1:=xlAscending, _
      Header:=xlGuess
  Cells(1, ncol + 1).EntireColumn.Delete
End Sub

Tri

Italic en second
Gras en troisième
Barré en 4e

TriGrasItalBarré

Sub TriCol()
  Columns("B:B").Insert Shift:=xlToRight
  For i = 2 To [a65000].End(xlUp).Row
    Cells(i, 2) = 1
    If Cells(i, 1).Font.Bold Then Cells(i, 2) = 3
    If Cells(i, 1).Font.Italic Then Cells(i, 2) = 2
    If Cells(i, 1).Font.Strikethrough Then Cells(i, 2) = 4
   Next
   [A2].CurrentRegion.Sort Key1:=[B2], Order1:=xlAscending, Header:=xlYes
   [B:B].Delete Shift:=xlToLeft
End Sub

Conserve le focus après tri

TriFocus

Sub TriNom()
  nom = Cells(ActiveCell.Row, 1)
  col = ActiveCell.Column
  [A2:C1000].Sort key1:=[A2]
  On Error Resume Next
  [a:a].Find(what:=nom).Offset(, col - 1).Select
End Sub

Tri dans l'ordre numérique de valeurs alphanumériques

Tri Numérique
Tri Numérique2
Tri AlphaNumSansDoublons

Sub triColInter2()
  [b:b].Insert
  For Each c In Range([A2], [a65000].End(xlUp))
    c.Offset(0, 1) = Val(c)
  Next c
  Range("A2").CurrentRegion.Select
  Selection.Offset(1).Resize(Selection.Rows.Count - 1).Select
  Selection.Sort Key1:=[B2]
  [b:b].Delete
End Sub

Tri AlphaNum Plusieurs séquences

Choix de la colonne de tri dans une liste

TriMenu

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Address = "$G$2" And Target.Count = 1 Then
     col = Application.Match(Target, [A1:D1], 0) - 1
     Range("A2:D30").Sort Key1:=[A1].Offset(0, col)
   End If
End Sub

Tri dynamique

Le tri est effectué à chaque saisie d'un nom

Tri Dynamique

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 1 And Target.Count = 1 Then
    m = Target
    [A2:C1000].Sort Key1:=[A2]
    [A:A].Find(What:=m, LookIn:=xlValues).Select
  End If
End Sub

 

Tri par groupe

TriGroupe

Sub TriCol()
  Columns("B:B").Insert Shift:=xlToRight
  i = 1
  Do While i <= [a65000].End(xlUp).Row
    temp = Cells(i, 1)
    Cells(i, 2) = temp
    i = i + 1
    Do While Not Left(Cells(i, 1), 1) = "[" And i <= [a65000].End(xlUp).Row
      Cells(i, 1).Offset(0, 1) = temp & Cells(i, 1)
      i = i + 1
    Loop
  Loop
  [A1].CurrentRegion.Sort Key1:=[B2], Order1:=xlAscending, Header:=xlNo
  [B:B].Delete Shift:=xlToLeft
End Sub

Tri les Blocs

Les blocs sont repérés par une couleur. Il n'y a pas de quadrillage.

Tri Blocs

Sub Tri()
  nbCol = [A1].CurrentRegion.Columns.Count
  couleurPremier = [A1].Interior.ColorIndex
  Columns("A:A").Offset(0, nbCol).Insert Shift:=xlToRight
  i = 1
  Do While i <= [a65000].End(xlUp).Row
    temp = Cells(i, 1)
    Cells(i, 1).Offset(0, nbCol) = temp
    i = i + 1
    Do While Cells(i, 1).Interior.ColorIndex <> couleurPremier And i <= [a65000].End(xlUp).Row
      Cells(i, 1).Offset(0, nbCol) = temp
      i = i + 1
    Loop
  Loop
  [A1].CurrentRegion.Sort Key1:=Range("A1").Offset(0, nbCol), Order1:=xlAscending, Header:=xlNo
  [A:A].Offset(0, nbCol).Delete Shift:=xlToLeft
End Sub

Tri suivant les titres en gras

TriCol

Sub TriCol()
  Columns("B:B").Insert Shift:=xlToRight
  i = 1
  Do While i <= [a65000].End(xlUp).Row
    temp = Cells(i, 1)
    Cells(i, 2) = temp
    i = i + 1
    Do While Not Cells(i, 1).Font.Bold And i <= [a65000].End(xlUp).Row
       Cells(i, 1).Offset(0, 1) = temp & Cells(i, 1)
       i = i + 1
    Loop
  Loop
  [A1].CurrentRegion.Sort Key1:=[B2], Order1:=xlAscending, Header:=xlNo
  [B:B].Delete Shift:=xlToLeft
End Sub

Tri de fiches

Tri Fiches
Tri Fiches2
Tri Fiches Colonne

Sub Tri(LigneDébut, HauteurBloc, numCol, ordre, DecalTri)
  nbcol = Cells(LigneDébut, 1).CurrentRegion.Columns.Count
  Columns("A:A").Offset(0, nbcol).Insert Shift:=xlToRight
  i = LigneDébut
  Do While i <= [a65000].End(xlUp).Row
    Cells(i, nbcol + 1).Resize(HauteurBloc, 1) = Cells(i + DecalTri, numCol)
    i = i + HauteurBloc
  Loop
  derLig = Cells(65000, nbcol + 1).End(xlUp).Row
  Range(Cells(LigneDébut, 1), Cells(derLig, nbcol + 1)).Sort _
     Key1:=Cells(LigneDébut + 1, 1).Offset(0, nbcol), Order1:=ordre, Header:=xlNo
  [A:A].Offset(0, nbcol).Delete Shift:=xlToLeft
End Sub

Sub triNom()
  Tri 7, 3, 1, xlAscending, 0
End Sub

Sub triDateNaissance()
  Tri 7, 3, 3, xlDescending, 0
End Sub

Sub triDateEntrée()
  Tri 7, 3, 2, xlAscending, 0
End Sub

Tri sur la couleur de fond

Tri Couleur Fond
Tri Couleur Fond2

Tri cadres

Tri Cadres

Sub Tri2()
  Set debut = Range("A1") ' à adapter
  n = debut.CurrentRegion.Rows.Count
  nf = ActiveSheet.Name
  Sheets.Add
  ActiveSheet.Name = "temp"
  Sheets(nf).Select
  debut.CurrentRegion.Copy Sheets("temp").[A1]
  nbcol = debut.CurrentRegion.Columns.Count
  debut.Offset(0, nbcol).EntireColumn.Insert Shift:=xlToRight
  debut.Offset(1, nbcol) = 1
  debut.Offset(1, nbcol).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
    Step:=1, Stop:=n - 1, Trend:=False
  debut.Resize(n, nbcol + 1).Sort Key1:=debut.Offset(1, 0), Order1:=xlAscending, Header:=xlGuess
  For i = 1 To n - 1
    x = debut.Offset(i, nbcol) + 1
    Sheets("temp").Cells(x, 1).Resize(, nbcol).Copy debut.Offset(i, 0)
  Next i
  debut.Offset(0, nbcol).EntireColumn.Delete
  Application.DisplayAlerts = False
  Sheets("temp").Delete
End Sub

Tri avec images

TriImages

Il faut que les images aient la propriété Déplacer

Sub modifieMove()
  For Each c In ActiveSheet.Shapes
    If c.Type = 13 Then c.Placement = xlMoveAndSize
  Next c
End Sub

Sub Tri()
   [A1].CurrentRegion.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False
End Sub

Tri sur double-clic sur le titre

TriTitre
TriTitre2

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Set titre = [A1:D1]
  If Not Intersect(titre, Target) Is Nothing And Target <> "" Then
    OrdreTri = IIf(Target.Interior.ColorIndex = 3, xlDescending, xlAscending)
    Target.CurrentRegion.Sort Key1:=Cells(1, Target.Column), Order1:=OrdreTri, Header:=xlGuess
    m = IIf(Target.Interior.ColorIndex = 3, 4, 3)
    titre.Interior.ColorIndex = 44
    Target.Interior.ColorIndex = m
  End If
  Cancel = True
End Sub

Tri sur le 3e caractère dans un ordre prédéfini (GPBO)

TriCode

Sub Macro1()
  Set debut = [A2]
  debut.Offset(, 1).EntireColumn.Insert
  Set plage = debut.Resize(debut.CurrentRegion.Rows.Count - 1)
  For Each c In plage
    c.Offset(, 1) = Left(c, 2) & InStr("GPBO", Mid(c, 3, 1)) & Mid(c, 4)
  Next c
  plage.Resize(, 2).Sort Key1:=debut.Offset(, 1), Order1:=xlAscending, Header:=xlGuess
  debut.Offset(, 1).EntireColumn.Delete
End Sub

Tri avec apostrophes

Les mots avec apostrophes sont regroupés.

TriApostrophes

Sub TriApostrophe()
  [b:b].Insert
  For Each c In Range([A2], [a65000].End(xlUp))
    c.Offset(0, 1) = Replace(c, "'", " ")
  Next c
  Range("A2").CurrentRegion.Select
  Selection.Sort Key1:=[B2], Header:=xlGuess
  [b:b].Delete
End Sub

Tri multi-feuilles

Feuil1 , Feuil2, Feuil3 contiennent chacune 50.000 lignes

-On fusionne Feuil1+Feuil2+Feuil3
-On tri l'ensemble
-L'ensemble est découpé sur Feuil4,Feuil5,Feuil6

TriMultiFeuilles

Tri des onglets

Tri Onglets.xls
Tri Onglet Ordre

Sub tri_ongletDirect()
  Application.ScreenUpdating = False
  For i = 1 To Sheets.Count
    For j = i To Sheets.Count
      If UCase(Sheets(j).Name) < UCase(Sheets(i).Name) Then
        Sheets(i).Move before:=Sheets(j)
        Sheets(j).Move before:=Sheets(i)
      End If
    Next j
  Next i
End Sub

Noms d' onglets numériques et alpha

Sub tri_ongletDirect2()
   Application.ScreenUpdating = False
   For i = 1 To Sheets.Count
     For j = i To Sheets.Count
       If IsNumeric(Sheets(j).Name) Then
         x = String(30 - Len(Sheets(j).Name), "0") & Sheets(j).Name
       Else
         x = UCase(Sheets(j).Name)
     End If
     If IsNumeric(Sheets(i).Name) Then
       y = String(30 - Len(Sheets(i).Name), "0") & Sheets(i).Name
     Else
       y = UCase(Sheets(i).Name)
     End If
    If x < y Then
      Sheets(i).Move before:=Sheets(j)
      Sheets(j).Move before:=Sheets(i)
    End If
   Next j
  Next i
End Sub

Tri dans une feuille temporaire

Sub trionglet2()
   Sheets.Add
   ActiveSheet.Name = "Tempo_jb"
   For i = 1 To Sheets.Count
      Cells(i, 1) = "'" & Sheets(i).Name
   Next i
   Range("A1:A256").Sort Key1:=Range("A1")
   For i = 1 To Sheets.Count
      nonglet = Cells(i, 1)
      Sheets(nonglet).Move before:=Sheets(i)
      Sheets("Tempo_jb").Activate
   Next i
   Application.DisplayAlerts = False
   Sheets("Tempo_jb").Delete
   Sheets(1).Activate
End Sub

Tri dans un tableau

Sub tri_onglet()
Application.ScreenUpdating = False
Dim a(256)
n = Sheets.Count
For i = 1 To n
a(i) = Sheets(i).Name
Next i
'---- tri
For i = 1 To n
For j = i To n
If a(j) < a(i) Then
temp = a(j)
a(j) = a(i)
a(i) = temp
End If
Next j
Next i
'---
For i = 1 To n
Sheets(a(i)).Move before:=Sheets(i)
Next i
Sheets(1).Select
End Sub

Tri Quick-Sort

Le principe est le suivant:

On répartit la suite de nombres à trier de telle sorte que tous les éléments inférieurs à un élément de référence (36 sur l'exemple) soient à gauche de celui-ci et que tous ceux qui lui sont supérieurs à sa droite.

[70 61 16 48 29 18 59 36 3 70 3 22 39 30 58 10] <- Avant
                                  ¦
             Elément médian de référence
                             ¦
[3 30 16 22 29 18] 36 [70 59 48 39 59 61 58 70] <- Après

               ¦                              ¦
Eléments<36                   Eléments>36

Tous les éléments de l'ensemble de droite sont supérieurs à ceux de l'ensemble de gauche. En procédant de la même façon sur les 2 sous-ensembles générés,on obtient 4 sous-ensembles ordonnés entre eux. Lorsque la taille des ensembles devient égale à 1,les nombres sont triés.

Choix de l'élément de référence:

Pour obtenir des sous-ensembles de tailles équilibrées,il faut que l'élément de référence ne soit ni trop petit,ni trop grand.

La méthode classique consiste à choisir l'élément de référence parmi 3 éléments:Ceux de gauche,du milieu et de droite.
Nous observons qu'en choisissant l'élément de référence au milieu de la liste à traiter, le temps de tri est le même.

Remarques:

-Si la liste est déja triée,le temps de tri n'augmente pas lorsque l'élément de référence est choisi au milieu,ce qui n'est pas le cas lorsqu'il est choisi à gauche.
-Le programme proposé est récursif.

TriQuick-Sort.xls
Compare Tri

Option Compare Text
Sub essai()
  Dim temp(10000) As Double
  For i = 1 To 10000
     temp(i) = Rnd
  Next i
  t = Timer
  Call tri(temp, 1, 10000)
  MsgBox Timer - t
End Sub

Sub tri(a() As Double, gauc, droi) ' Quick sort
   ref = a((gauc + droi) \ 2)
   g = gauc: d = droi
   Do
      Do While a(g) < ref: g = g + 1: Loop
      Do While ref < a(d): d = d - 1: Loop
        If g <= d Then
           temp = a(g): a(g) = a(d): a(d) = temp
           g = g + 1: d = d - 1
        End If
    Loop While g <= d
    If g < droi Then Call tri(a, g, droi)
    If gauc < d Then Call tri(a, gauc, d)
End Sub

Tri avec caractères accentués

Sub tri(a, gauc, droi) ' Quick sort
  ref = sansAccent(a((gauc + droi) \ 2))
  g = gauc: d = droi
  Do
    Do While sansAccent(a(g)) < ref: g = g + 1: Loop
    Do While ref < sansAccent(a(d)): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call tri(a, g, droi)
  If gauc < d Then Call tri(a, gauc, d)
End Sub

Function sansAccent(chaine)
  codeA = "ÉÈÊËÔéèêëàçùôûïî"
  codeB = "EEEEOeeeeacuouii"
  temp = chaine
  For i = 1 To Len(temp)
    p = InStr(codeA, Mid(temp, i, 1))
    If p > 0 Then Mid(temp, i, 1) = Mid(codeB, p, 1)
  Next
  sansAccent = temp
End Function

Tri matriciel

TriMatriciel

La formule matricielle est écrite une seule fois dans un champ.

-Sélectionner D2:D1000
=INDEX(champ;EQUIV(GRANDE.VALEUR(NB.SI(champ;">="&champ);LIGNE(INDIRECT("1:"&LIGNES(champ))));
NB.SI(champ;">="&champ);0))
-Valider avec Maj+ctrl+entrée

-Pour 1.000 éléments, si on modifie une cellule, temps recalcul = 1sec

Fonction liste triée

Cette fonction personalisée matricielle permet d'obtenir une liste triée . Elle est beaucoup +rapide qu'avec une formule matricielle:

-Matricielle :  1.000 éléments --> 1sec
-VBA:              10.000 éléments --> 0,15 sec

Fonction liste triée

Option Compare Text
Function ListeTriée(champ As Range)
  Application.Volatile
  temp = champ.Value
  Dim b()
  ReDim b(1 To Application.Caller.Rows.Count)
  n = 0
  For Each c In temp
     If c <> "" Then
         n = n + 1
         b(n) = c
     End If
  Next
  Call tri(b, 1, n)
  ListeTriée = Application.Transpose(b)
End Function

Tri multi-zones

-Sélectionner E2:E17
=ListeTriéeMZ((A2:A6;A9:A13;A17:A21))
-Valider avec maj+ctrl+entrée

ListeTriéeMultiZones

Function ListeTriéeMZ(champ As Range)
  Application.Volatile
  Dim b()
  ReDim b(1 To Application.Caller.Rows.Count)
  n = 0
  For i = 1 To champ.Areas.Count ' parcours des zones du champ multi-zones
    For j = 1 To champ.Areas(i).Count ' parcours des éléments d'une zone
      If champ.Areas(i)(j) <> "" And champ.Areas(i)(j) <> "." Then
         n = n + 1
         b(n) = champ.Areas(i)(j)
      End If
    Next j
  Next i
  Call Tri(b, 1, n)
  ListeTriéeMZ = Application.Transpose(b)
End Function

Tri multi-feuilles

Tri Multi Feuilles

 

 

 


 

 

 

 

 

 

Exemples

Tri Synthèse
Tri Blocs
Tri Blocs
Tri Blocs4
Tri Onglets.xls
Tri Email.xls
Tri Quick-Sort
Tri Nom Prenom
Tri Couleur Fond
Tri Couleur Fond2
Tri Onglet Ordre
Tri Liste Déroulante
Tri Numérique
Tri Numérique2
Tri Cellule
Tri 6Colonnes
Tri Dynamique
Tri Dynamique2
Tri Dynamique3
Tri Matriciel
Tri Multi-Zones
Tri Double Clic Colonne
Tri Nombre Caractères
Tri Images
Tri Cadres
Tri Sans Articles
Tri Protection
Tri SansCivilité
Tri AlphaNumSansDoublons
TriCouleur
TriCommentaire
TriMultiFeuilles
TriNbOccur
FonctionSansDoublonsTriée
FonctionTri
FonctionSansDoublonsTriéeMultiZones