Tri par ordre alphabétique au sein d'une même cellule

[eramond]

Bonjour

Je souhaite trier le contenue d'une cellule par ordre alphabétique, est ce possible?

Exemple si C2 contient:
Thierry
Bernard

Après la macro

C2 =
Bernard
Thierry


Merci

 

[Dranreb]

Re : Tri par ordre alphabétique au sein d'une même cellule

Bonjour.

Vu qu'avec mon module de classe TableIndex on arrive à classer n'importe quoi…

 

[eramond]

Re : Tri par ordre alphabétique au sein d'une même cellule

Merci beaucoup c'est exactement ce que je voulais !

J'ai exporter le module et la table sur mon fichier d'orginie, où dois je lui indiquer la colonne à trier?

 

[Dranreb]

Re : Tri par ordre alphabétique au sein d'une même cellule

Les deux modules: le module standard Module1 qui contient cette Function ZLFClassé et le module de classe TableIndex qui définit ce type d'objet.

 

[eramond]

Re : Tri par ordre alphabétique au sein d'une même cellule

Merci

En fait c'est la colonne AI de l'onglet data-deviations que je souhaitre trier. Pour l'instant je n'y parviens pas.

Pour info la colone AI se remplit grêce à une macro ( module 1) qui fait un recherche v amélioré entre la colonne AG et les colonnes S&T de la feuille Work on

 

[Dranreb]

Re : Tri par ordre alphabétique au sein d'une même cellule

Travaillez donc uniquement avec des tableaux VBA en mémoire: c'est beaucoup plus rapide.

Essayez en vous servant de ça:

Option Explicit
Dim Te(1 To 500) As String, Le As Long

Sub Ajouter(ByVal Z As String)
Le = Le + 1: Te(Le) = Z
End Sub

Function RésultatCellClassé() As String
Dim Ts() As String, Ls&
ReDim Ts(0 To Le - 1): Ls = -1
With New TableIndex
   .Init 1, Le: While .Actif: .BInfA = Te(.B) < Te(.A): Wend
   .Parcourir: While .Actif: Le = .Suivant: Ls = Ls + 1: Ts(Ls) = Te(Le): Wend: End With
RésultatCellClassé = Join(Ts, vbLf)
Le = 0
End Function

 

[eramond]

Re : Tri par ordre alphabétique au sein d'une même cellule

Que voulez vous dire par tableaux VBA en mémoire ?

 

[Dranreb]

Re : Tri par ordre alphabétique au sein d'une même cellule

Des trucs déclarés avec () derrière.
On peut y affecter directement des Value de Range en une seule instruction. Pareil dans l'autre sens.
La durée d'exécution d'une macro est essentiellement proportionnelle au nombre de fois qu'on utilise la méthode Range, et ne dépend presque pas du nombre de valeurs de cellules transférées à chacune de ses utilisations. 1000 Range d'une cellule est 1000 fois plus long qu'un seul Range de 1000 cellules. Je propose donc très souvent des codes où je n'en ai que deux: un au début: Te = PlageEntrée.Value et un autre à la fin: PlageSortie.Value = Ts

 

[eramond]

Re : Tri par ordre alphabétique au sein d'une même cellule

Merci alors j'ai bricole un peu mon fichier en insérant votre feuille et avec un = les données triées reviennent dans le tableau adéquat

Par contrepour optimier mes Ranges comme vous le dites je ne vois pas où puis je les enlever d'ici

  For Each Cel In WsC.Range("AG2:AG" & WsC.Range("AG" & Rows.Count).End(xlUp).Row)
        MemoPos = 1000
        For Each c In WsS.Range("S2:S" & WsS.Range("S" & Rows.Count).End(xlUp).Row)
            Position = InStr(Cel, c)
            If Position > 0 Then
                If Cel.Offset(0, 2) <> "" And InStr(Cel.Offset(0, 2), c.Offset(0, 1)) = 0 Then
                ' ligne And InStr(Cel.Offset(0, 2), C.Offset(0, 1)) = 0 supprime doublon
                If Position < MemoPos Then
                        MemoPos = Position
                        Cel.Offset(0, 2) = c.Offset(0, 1) & Chr(10) & Cel.Offset(0, 2)
                    Else
                        Cel.Offset(0, 2) = Cel.Offset(0, 2) & Chr(10) & c.Offset(0, 1)
                    End If
                Else
                    Cel.Offset(0, 2) = c.Offset(0, 1)
                    MemoPos = Position
                End If
            End If
        Next c
    Next Cel
    Set WsC = Nothing: Set WsS = Nothing

 

[BOISGONTIER]

Re : Tri par ordre alphabétique au sein d'une même cellule

Bonjour,

Exemple en PJ

JB

 

[eramond]

Re : Tri par ordre alphabétique au sein d'une même cellule

Merci mais visiblement la function ne marche pas dans un tableau.

J'ai copier votre module et effectué un =Tricell, le résultat ne fonctionne pas.

 

[Dranreb]

Re : Tri par ordre alphabétique au sein d'une même cellule

Par contrepour optimier mes Ranges comme vous le dites je ne vois pas où puis je les enlever d'ici

C'est très simple: vous les enlevez tous au milieu, dans les boucles, et vous n'en laissez qu'au début et à la fin. Et dans les boucles vous accédez uniquement, à la vitesse de la lumière, aux éléments de tableaux, les uns en entrée (ceux initialisés par les Range du début) d'autre en sortie (ceux à destination des Range de fin)

 

[eramond]

Re : Tri par ordre alphabétique au sein d'une même cellule

Merci:

mon code est passé de ceci :

Sub Test()
 Application.ScreenUpdating = False
Dim WsS As Worksheet, WsC As Worksheet
Dim Cel As Range, c As Range
Dim Position As Integer, MemoPos As Integer
    Set WsS = Worksheets("Workon")
    Set WsC = Worksheets("Data-Deviations")
   
    Sheets("Data-Deviations").Activate
 Range("AI2:AI1000000").ClearContents
 
    
  For Each Cel In WsC.Range("AG2:AG" & WsC.Range("AG" & Rows.Count).End(xlUp).Row)
        MemoPos = 1000
        For Each c In WsS.Range("S2:S" & WsS.Range("S" & Rows.Count).End(xlUp).Row)
            Position = InStr(Cel, c)
            If Position > 0 Then
                If Cel.Offset(0, 2) <> "" And InStr(Cel.Offset(0, 2), c.Offset(0, 1)) = 0 Then
                ' ligne And InStr(Cel.Offset(0, 2), C.Offset(0, 1)) = 0 supprime doublon
                If Position < MemoPos Then
                        MemoPos = Position
                        Cel.Offset(0, 2) = c.Offset(0, 1) & Chr(10) & Cel.Offset(0, 2)
                    Else
                        Cel.Offset(0, 2) = Cel.Offset(0, 2) & Chr(10) & c.Offset(0, 1)
                    End If
                Else
                    Cel.Offset(0, 2) = c.Offset(0, 1)
                    MemoPos = Position
                End If
            End If
        Next c
    Next Cel
    Set WsC = Nothing: Set WsS = Nothing
    Application.ScreenUpdating = True
    
End Sub

A ceci

Sub Test()
 Application.ScreenUpdating = False
Dim WsS As Worksheet, WsC As Worksheet
Dim Cel As Range, c As Range
Dim Position As Integer, MemoPos As Integer
    Set WsS = Worksheets("Workon")
    Set WsC = Worksheets("Data-Deviations")
     Dim Te As PlageEntrée.Value
     Dim Ts As PlageSortie.Value
     
     'Te = PlageEntrée.Value et un autre à la fin: PlageSortie.Value = Ts
    
   
    Sheets("Data-Deviations").Activate
 Range("AI2:AI1000000").ClearContents
 
    
  For Each Te In WsC.Range("AG2:AG" & WsC.Range("AG" & Rows.Count).End(xlUp).Row)
        MemoPos = 1000
        For Each Ts In WsS.Range("S2:S" & WsS.Range("S" & Rows.Count).End(xlUp).Row)
            Position = InStr(Te, Ts)
            If Position > 0 Then
                If Te.Offset(0, 2) <> "" And InStr(Te.Offset(0, 2), Ts.Offset(0, 1)) = 0 Then
                ' ligne And InStr(Cel.Offset(0, 2), C.Offset(0, 1)) = 0 supprime doublon
                If Position < MemoPos Then
                        MemoPos = Position
                        Te.Offset(0, 2) = Ts.Offset(0, 1) & Chr(10) & Te.Offset(0, 2)
                    Else
                        Te.Offset(0, 2) = Cel.Offset(0, 2) & Chr(10) & Ts.Offset(0, 1)
                    End If
                Else
                    Te.Offset(0, 2) = Ts.Offset(0, 1)
                    MemoPos = Position
                End If
            End If
        Next Ts
    Next Te
    Set WsC = Nothing: Set WsS = Nothing
    Application.ScreenUpdating = True
    
End Sub

Mais cela ne fonctionne pas

 

[eramond]

Re : Tri par ordre alphabétique au sein d'une même cellule

Bonjour,

Exemple en PJ

JB

Cela fonctionne merci !

comment puis l'intégrer dans cette macro ?

Sub Test()
 Application.ScreenUpdating = False
Dim WsS As Worksheet, WsC As Worksheet
Dim Cel As Range, c As Range
Dim Position As Integer, MemoPos As Integer
    Set WsS = Worksheets("Workon")
    Set WsC = Worksheets("Data-Deviations")
   
    Sheets("Data-Deviations").Activate
 Range("AI2:AI1000000").ClearContents
 
    
  For Each Cel In WsC.Range("AG2:AG" & WsC.Range("AG" & Rows.Count).End(xlUp).Row)
        MemoPos = 1000
        For Each c In WsS.Range("S2:S" & WsS.Range("S" & Rows.Count).End(xlUp).Row)
            Position = InStr(Cel, c)
            If Position > 0 Then
                If Cel.Offset(0, 2) <> "" And InStr(Cel.Offset(0, 2), c.Offset(0, 1)) = 0 Then
                ' ligne And InStr(Cel.Offset(0, 2), C.Offset(0, 1)) = 0 supprime doublon
                If Position < MemoPos Then
                        MemoPos = Position
                        Cel.Offset(0, 2) = c.Offset(0, 1) & Chr(10) & Cel.Offset(0, 2)
                    Else
                        Cel.Offset(0, 2) = Cel.Offset(0, 2) & Chr(10) & c.Offset(0, 1)
                    End If
                Else
                    Cel.Offset(0, 2) = c.Offset(0, 1)
                    MemoPos = Position
                End If
            End If
        Next c
    Next Cel
    Set WsC = Nothing: Set WsS = Nothing
    Application.ScreenUpdating = True
    
End Sub

JE voudrais faire le tricell des celluls AI sheet data déviations une fois la macro finis

 

[Dranreb]

Re : Tri par ordre alphabétique au sein d'une même cellule

Non la structure à observer serait plutôt dans ce style :

TDévia = WsC.Range("AG2:AH" & WsC.Range("AG" & Rows.Count).End(xlUp).Row).Value
TWorkon = WsC.Range("AG2:AG" & WsC.Range("AG" & Rows.Count).End(xlUp).Row).Value
For Ld = 1 To UBound(TDévia)
   mempos = 1000
   For Lw = 1 To UBound(TWorkon)
      Position = InStr(TDévia(Ld, 1), TWorkon(Lw, 1))
      If Position > 0 Then
          etc.

Avec cette version de la fonction RésultatCellClassé vous devriez pouvoir empiler les doublons avec Ajouter. C'est facile de les repérer après classement pour les éliminer puisqu'ils se retrouvent ensembles.

Function RésultatCellClassé() As String
Dim Ts() As String, Ls&, Texte As String
ReDim Ts(0 To Le - 1): Ls = -1
With New TableIndex
   .Init 0, Le: While .Actif: .BInfA = Te(.B) < Te(.A): Wend
   Texte = ""
   .Parcourir: While .Actif: Le = .Suivant
      If Te(Le) <> Texte Then Texte = Te(Le): Ls = Ls + 1: Ts(Ls) = Texte
      Wend: End With
ReDim Preserve Ts(0 To Ls)
RésultatCellClassé = Join(Ts, vbLf)
Le = 0
End Function