XL 2010 Tri alphabétique sur plusieurs colonnes

[jokerfidelio]

Bonjour a tous,
J ai essayé plusieurs code vba mais sans succès.

J aurais souhaité pouvoir trier les données de plusieurs colonne
exemple B.D.F par ordre alphabétique (avec suite sur les 3 colonnes de A 》Z)
automatiquement a chaque nouvelles entrée ou a l ouverture du fichier.

Merci de votre aide

 

[phlaurent55]

Bonjour joker,

voir fichier joint

à+
Philippe

 

[jokerfidelio]

merci pour ton travail phlaurent55

mais j'aurais besoin d'un tri alphabetique sur ces 3 colonnes mais qui ce suivent sans interuption de cette ordre alphabetique jusqu'a la fin de la troisiéme colonne :

resultat souhaité sur les colonne B.D.F

tri alphabetique de A a Z jusque ligne 22 et suite sur colonne D idem maxi ligne 22 et finir sur colonne F maxi ligne 22

avec misa a jour automatique si nouvelle entree peu importe ou sur le tableau

fichier joint pour exemple

merci d'avance

 

[riton00]

Bonjour jokerfidelio, phlaurent55

Peut-être comme ça?

Slts

 

[jokerfidelio]

après essai du nouveau fichier, le tri alphabétique et toujours réalisé mais sur une colonne unique exemple ; de "B2" a "B23" tri de A a Z
mais l'objectif du tri sur les 3 colonnes serait qu'il y ait une continuité sur l'ensemble des 3 colonnes et déplacement du noms a la bonne place :

exemple :
les premieres lettres de l'alphabets sur la premiere colonne et pour finir sur la troisiéme colonne les dernieres lettre de l'aphabet.
Dans l'idee si ajout du nom avec la lettre A dans la derniere colonne en "F" automatiquement replacé a sa place sur la premiere colonnes

 

[Dranreb]

Bonsoir.
Pour ceux qui auraient mon module de classe TableIndex :

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim T1(), L1&, T2(), L2&, C&
T1 = [A2:F23].Value
ReDim T2(1 To UBound(T1, 1) * 3, 1 To 2)
For C = 1 To 5 Step 2: For L1 = 1 To UBound(T1, 1)
  L2 = L2 + 1: T2(L2, 1) = T1(L1, C): T2(L2, 2) = T1(L1, C + 1)
  Next L1, C
With New TableIndex
  .Init 1, UBound(T2, 1)
  While .Actif
  Select Case VarType(T2(.B, 2)) - VarType(T2(.A, 2))
     Case 0: .BInfA = T2(.B, 2) < T2(.A, 2)
     Case Is < 0: .BInfA = False: Case Else: .BInfA = True
     End Select: Wend
  .Parcourir
  For C = 1 To 5 Step 2: For L1 = 1 To UBound(T1, 1)
     L2 = .Suivant
     T1(L1, C) = T2(L2, 1): T1(L1, C + 1) = T2(L2, 2)
     Next L1, C: End With
Application.EnableEvents = False
[A2:F23].Value = T1
Application.EnableEvents = True
End Sub

 

[job75]

Bonsoir à tous,

Fichier joint avec cette macro :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim nlig&
nlig = Application.CountA([A:A]) - 1
If nlig = 0 Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
[C2].Resize(nlig, 2).Cut Cells(nlig + 2, 1)
[E2].Resize(nlig, 2).Cut Cells(2 * nlig + 2, 1)
[A:B].Sort [B1], xlAscending, Header:=xlYes 'tri
Cells(2 * nlig + 2, 1).Resize(nlig, 2).Cut [E2]
Cells(nlig + 2, 1).Resize(nlig, 2).Cut [C2]
Application.EnableEvents = True
End Sub

Bonne nuit.

 

[job75]

Re,

Une version nettement plus élaborée :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim nlig&
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
'---tri---
nlig = [A:F].Find("*", , xlValues, , xlByRows, xlPrevious).Row - 1
[C2].Resize(nlig, 2).Cut Cells(nlig + 2, 1)
[E2].Resize(nlig, 2).Cut Cells(2 * nlig + 2, 1)
[A:B].Sort [B1], xlAscending, [A1], , xlAscending, Header:=xlYes 'tri
Cells(2 * nlig + 2, 1).Resize(nlig, 2).Cut [E2]
Cells(nlig + 2, 1).Resize(nlig, 2).Cut [C2]
'---mise en forme---
With [A1].CurrentRegion.Resize(, 6)
  .Borders.Weight = xlThin 'bordures
  .Offset(1).SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = xlNone
  .Offset(.Rows.Count).Resize(Rows.Count - .Rows.Count).Delete xlUp
End With
Application.EnableEvents = True
With Me.UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Fichier (2).

A+

 

[libellule85]

Bonjour à vous tous, bonjour au forum,

Je viens d'essayer la macro de Dranreb pour le même genre de tableau simplement les données vont du a4 au f43 (l'intitulé des colonnes se trouvent sur la ligne 3)
Quand je rajoute un nom une erreur se produit 'Erreur de compilation - type défini par l'utilisateur non défini". Cette erreur se situe au niveau "With New TableIndex" et n'étant pas très férue en vba je ne sais pas quoi modifier ou rajouter à cette macro.
De plus serait-il possible que la macro se déclenche une fois le nom écrit, car actuellement elle fonctionne dès que l'on entre un n°.
D'avance merci beaucoup pour votre aide

Private Sub Worksheet_Change(ByVal Target As Range)
Dim T1(), L1&, T2(), L2&, C&
T1 = [A4:F43].Value
ReDim T2(1 To UBound(T1, 1) * 3, 1 To 2)
For C = 1 To 5 Step 2: For L1 = 1 To UBound(T1, 1)
  L2 = L2 + 1: T2(L2, 1) = T1(L1, C): T2(L2, 2) = T1(L1, C + 1)
  Next L1, C
With New TableIndex
  .Init 1, UBound(T2, 1)
  While .Actif
  Select Case VarType(T2(.B, 2)) - VarType(T2(.A, 2))
     Case 0: .BInfA = T2(.B, 2) < T2(.A, 2)
     Case Is < 0: .BInfA = False: Case Else: .BInfA = True
     End Select: Wend
  .Parcourir
  For C = 1 To 5 Step 2: For L1 = 1 To UBound(T1, 1)
     L2 = .Suivant
     T1(L1, C) = T2(L2, 1): T1(L1, C + 1) = T2(L2, 2)
     Next L1, C: End With
Application.EnableEvents = False
[A4:F43].Value = T1
Application.EnableEvents = True
End Sub

 

[job75]

Bonjour le fil, libellule85,

Dans ce fichier (2 bis) le tableau est trié uniquement quand on modifie un nom.

De plus les noms sont mis automatiquement en majuscules :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim nlig&
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
Set Target = Intersect(Target, [B:B,D:D,F:F])
If Not Target Is Nothing Then
  '---noms en majuscules---
  For Each Target In Intersect(Target, Me.UsedRange) 'si entrées multiples
    If Target <> "" Then Target = UCase(Target)
  Next
  '---tri---
  nlig = [A:F].Find("*", , xlValues, , xlByRows, xlPrevious).Row - 1
  [C2].Resize(nlig, 2).Cut Cells(nlig + 2, 1)
  [E2].Resize(nlig, 2).Cut Cells(2 * nlig + 2, 1)
  [A:B].Sort [B1], xlAscending, [A1], , xlAscending, Header:=xlYes 'tri
  Cells(2 * nlig + 2, 1).Resize(nlig, 2).Cut [E2]
  Cells(nlig + 2, 1).Resize(nlig, 2).Cut [C2]
End If
'---mise en forme---
With [A1].CurrentRegion.Resize(, 6)
  .Borders.Weight = xlThin 'bordures
  .Offset(1).SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = xlNone
  .Offset(.Rows.Count).Resize(Rows.Count - .Rows.Count).Delete xlUp
End With
Application.EnableEvents = True
With Me.UsedRange: End With 'actualise la barre de défilement verticale
End Sub

A+

 

[Dranreb]

Bonjour.
Libellule: vous avez simplement oublié d'installer le module de classe TableIndex de mon classeur du poste #6 dans le votre.

 

[libellule85]

Bonjour job75, Dranreb,

Un grand grand merci à tous les deux pour votre aide....
@Dranreb : effectivement en mettant le module de classe cela fonctionne nettement mieux !!!

Bonne journée à vous deux et encore merci

 

[jokerfidelio]

super travail pile poil ce dont j'avais besoin. merci a tous

 

[job75]

Re,

Juste une remarque, pour que mes solutions (couper-coller) fonctionnent bien il ne faut pas de données au delà de la ligne :

- 349526 sur Excel 2007 et versions suivantes

- 21846 sur les versions antérieures à Excel 2007.

A+

 

[jokerfidelio]

Petite question :

j'aimerais faire cohabiter cette recherche en texbox :

Private Sub TextBox1_Change()
    Application.ScreenUpdating = False
    Range("B2:B25", "D2:D25", "F2:F25").Interior.ColorIndex = 2
    ListBox1.Clear
    liste_colonnes = Array(2, 4, 6) 'B D F

    If TextBox1 <> "" Then
        For ligne = 3 To 25
            For no_colonne = 0 To UBound(liste_colonnes)
                colonne = liste_colonnes(no_colonne)
                If Cells(ligne, colonne) Like "*" & TextBox1 & "*" Then
                    Cells(ligne, colonne).Interior.ColorIndex = 43
                    ListBox1.AddItem Cells(ligne, colonne)
                End If
            Next
        Next
    End If
End Sub

mais plus rien ne fonctionne correctement ! qu'elle est mon erreur ?