Tri alphanumerique

Le 28/09/2018 à 12:40

Bonjour,

je simplifie ma demande faites précédemment.

Dans le fichier joint, je cherche en partant du tableau de gauche avec des sigles M, A accompagnés d' un chiffre

à ressortir deux tableaux à droite M et A.

Ces tableaux me reportent le nom de la personne (colonne A) sur le chiffre concerné et le jour concerné.

Ci joint le résultat que je souhaiterais obtenir

Merci de votre aide

cordialement

15tseoy.xlsx (11.87 Ko)
Le 28/09/2018 à 13:26

Bonjour,

tseoy a écrit :

Ces tableaux me reportent le nom de la personne (colonne A) sur le chiffre concerné et le jour concerné

j'avais entamé assez simplement, mais je me suis aperçu qu'il pouvait y avoir plusieurs personnes !

Donc 2 solutions = l'une avec formules matricielles, l'autre plus souple est de reporter les données dans un tableau et faire 2 TCD

Me manque un peu de temps à l'instant pour le faire mais je vais m'y pencher !

Le 28/09/2018 à 14:23

Merci

Le 28/09/2018 à 15:05

Bonjour,

Une proposition à étudier.

Elle nécessite l'installation de Power Query (complément gratuit Microsoft).

Cdlt.

10tseoy.xlsx (27.31 Ko)
Le 28/09/2018 à 16:15

Merci de cette proposition, mais ce document est pour un usage professionnel.

Je ne peux installer quoi que ce soit dans l'entreprise.

Je cherche une formule Excel ou une macro.

Cordialement

TM

Le 28/09/2018 à 18:14

sauf erreur de ma part

17tseoy.xlsx (14.01 Ko)
Le 28/09/2018 à 18:53

OUAHH!

je vais essayer de le mettre à la grandeur de mon fichier .

Je vais étudier pour comprendre la formule qui m'a l'air complexe.

En tout cas merci beaucoup Steelson

Tseoy

Le 28/09/2018 à 19:44

Complexe en effet !

Ce serait sans doute plus simple en macro ...

Le 28/09/2018 à 22:12

Pouvez vous me faire une macro ?

Mais je commence à travailler avec la formule

Merci

Tseoy

Le 29/09/2018 à 05:39

Voici une version que j'ai l'habitude de réaliser :

  • je mets à plat les données sous forme de base de données
  • j'actualise ensuite un TCD
Sub creerBdD()

With Sheets("BdD")

    .Range("A1").CurrentRegion.Offset(1, 0).ClearContents
    ligne = 2
    For i = 3 To [A2].End(xlDown).Row
        For j = 2 To [A2].End(xlToRight).Column
            .Cells(ligne, 1) = Mid(Cells(i, j), 1, 1)
            .Cells(ligne, 2) = Mid(Cells(i, j), 2, 1)
            .Cells(ligne, 3) = Cells(2, j)
            .Cells(ligne, 4) = Cells(i, 1)
            ligne = ligne + 1
        Next
    Next

End With

Sheets("TCD").Select
ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotCache.Refresh

End Sub

mais la présentation est un peu différente ! et moins pro que la version de Jean-Eric mais je suis d'accord avec toi sur l'impossibilité de déployer PowerQuery au sein des entreprises (plus de 10.000 postes chez moi).

13tseoy.xlsm (28.09 Ko)
Le 29/09/2018 à 17:33

Autre version à condition que le cadre soit tracé et suffisant

Sub creerTableaux()

Dim cel1 As Range, cel2 As Range, cel3 As Range

    For i = 2 To [A2].End(xlDown).Row
        For j = 2 To [B1].End(xlToRight).Column

            Set cel1 = Rows(1).Find(What:=Mid(Cells(i, j), 1, 1), After:=Range("A1"), SearchDirection:=xlNext)
            Set cel2 = Rows(1).Find(What:=Cells(1, j), After:=cel1, SearchDirection:=xlNext)
            Set cel3 = Columns(cel1.Column).Find(What:=Mid(Cells(i, j), 2, 1), After:=cel1, SearchDirection:=xlNext)

            plus = 0
            Do Until Cells(cel3.Row + plus, cel2.Column) = ""
                plus = plus + 1
            Loop
            Cells(cel3.Row + plus, cel2.Column) = Cells(i, 1)

        Next
    Next

End Sub
12tseoy-v2.xlsm (17.91 Ko)
Le 29/09/2018 à 17:52

Merci de ton aide .

Je vais travailler sur mon document lundi au bureau.

En fait mon tableau représente les jours du mois (soit 30 ou 31) en horizontal

En vertical j'ai 70 lignes avec des noms.

Le but de mon travail est de sortir par jour (J.. ) par équipe (M et A) le nom des agents à leur étage (ici 6 à10)

Je vais reprendre ta macro et l'adapter à mon fichier réel.

Vous m'avez été d'une très grande aide.

tseoy

Le 30/09/2018 à 11:31

Bonjour,

je n'avais rien à me mettre sous la dent (ou les neurones), alors je me suis carrément fait plaisir !

Les chiffres se mettront à la bonne place

Sub creerTableaux()

Dim cel1 As Range, cel2 As Range, cel3 As Range, plage As Range, cel4 As Range
Dim dico As Object
Dim dicoTrie As Object
Set dico = CreateObject("Scripting.Dictionary")
Set dicoTrie = CreateObject("Scripting.Dictionary")
Set plage = Range("A1:A" & [A2].End(xlDown).Row)

    Set cel1 = Rows(1).Find(What:="M", After:=Range("A1"), SearchDirection:=xlNext)
    Set cel4 = Columns(cel1.Column).Find(What:="Fin de liste", After:=cel1, SearchDirection:=xlNext)
    If Not cel4 Is Nothing Then Range(cel1.Offset(1, 0), cel4.Offset(0, cel1.End(xlToRight).Column - cel1.Column)).ClearContents

    Set cel1 = Rows(1).Find(What:="A", After:=Range("A1"), SearchDirection:=xlNext)
    Set cel4 = Columns(cel1.Column).Find(What:="Fin de liste", After:=cel1, SearchDirection:=xlNext)
    If Not cel4 Is Nothing Then Range(cel1.Offset(1, 0), cel4.Offset(0, cel1.End(xlToRight).Column - cel1.Column)).ClearContents

    For i = 3 To [A2].End(xlDown).Row
        For j = 2 To [B1].End(xlToRight).Column
            If Not dico.Exists(Cle) Then dico.Add Cells(i, j), 1
        Next
    Next

    Tbl = dico.keys
    QuickSort Tbl

    For i = LBound(Tbl) To UBound(Tbl)
        For j = 2 To [B1].End(xlToRight).Column
            dicoTrie(Tbl(i)) = WorksheetFunction.Max(WorksheetFunction.CountIf(plage.Offset(0, j - 1), Tbl(i)), dicoTrie(Tbl(i)))
        Next
    Next i

    For Each Cle In dicoTrie.keys
        'Debug.Print Cle & " - " & dicoTrie(Cle)
    Next

    ici = 1
    For Each Cle In dicoTrie.keys
        If UCase(Mid(Cle, 1, 1)) = "M" Then
            Range("M").Offset(ici, 0).Value = Mid(Cle, 2, Len(Cle) - 1)
            ici = ici + dicoTrie(Cle) + 1
        End If
    Next
    Range("M").Offset(ici, 0).Value = "Fin de liste"

    ici = 1
    For Each Cle In dicoTrie.keys
        If UCase(Mid(Cle, 1, 1)) = "A" Then
            Range("A").Offset(ici, 0).Value = Mid(Cle, 2, Len(Cle) - 1)
            ici = ici + dicoTrie(Cle) + 1
        End If
    Next
    Range("A").Offset(ici, 0).Value = "Fin de liste"

    For i = 2 To [A2].End(xlDown).Row
        For j = 2 To [B1].End(xlToRight).Column

            Set cel1 = Rows(1).Find(What:=Mid(Cells(i, j), 1, 1), After:=Range("A1"), SearchDirection:=xlNext)
            Set cel2 = Rows(1).Find(What:=Cells(1, j), After:=cel1, SearchDirection:=xlNext)
            Set cel3 = Columns(cel1.Column).Find(What:=Mid(Cells(i, j), 2, Len(Cells(i, j)) - 1), After:=cel1, SearchDirection:=xlNext)

            plus = 0
            Do Until Cells(cel3.Row + plus, cel2.Column) = ""
                plus = plus + 1
            Loop
            Cells(cel3.Row + plus, cel2.Column) = Cells(i, 1)

        Next
    Next

End Sub

Public Sub QuickSort(vArray As Variant, _
  Optional ByVal inLow As Long = -1, _
  Optional ByVal inHi As Long = -1)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long
  inLow = IIf(inLow = -1, LBound(vArray), inLow)
  inHi = IIf(inHi = -1, UBound(vArray), inHi)
  tmpLow = inLow
  tmpHi = inHi
  pivot = vArray((inLow + inHi) \ 2)
  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend
     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend
     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend
  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub
6tseoy-v3.xlsm (22.39 Ko)
Le 30/09/2018 à 15:58

Je me suis affranchi dans cette nouvelle version de la dénomination des Cellules M et A

juste pour compliquer encore le bazar !

Sub creerTableaux()

Dim cel1 As Range, cel2 As Range, cel3 As Range, plage As Range, cel4 As Range
Dim dico As Object
Dim dicoTrie As Object
Set dico = CreateObject("Scripting.Dictionary")
Set dicoTrie = CreateObject("Scripting.Dictionary")
Set plage = Range("A1:A" & [A2].End(xlDown).Row)

    ' effacement des données de M - recherche de la fin de liste
    Set cel1 = Rows(1).Find(What:="M", After:=Range("A1"), SearchDirection:=xlNext)
    Set cel4 = Columns(cel1.Column).Find(What:="Fin de liste", After:=cel1, SearchDirection:=xlNext)
    If Not cel4 Is Nothing Then Range(cel1.Offset(1, 0), cel4.Offset(0, cel1.End(xlToRight).Column - cel1.Column)).ClearContents

    ' effacement des données de A - recherche de la fin de liste
    Set cel1 = Rows(1).Find(What:="A", After:=Range("A1"), SearchDirection:=xlNext)
    Set cel4 = Columns(cel1.Column).Find(What:="Fin de liste", After:=cel1, SearchDirection:=xlNext)
    If Not cel4 Is Nothing Then Range(cel1.Offset(1, 0), cel4.Offset(0, cel1.End(xlToRight).Column - cel1.Column)).ClearContents

    For i = 3 To [A2].End(xlDown).Row
        For j = 2 To [B1].End(xlToRight).Column
            If Not dico.Exists(Cle) Then dico.Add Cells(i, j), 1
        Next
    Next

    Tbl = dico.keys
    QuickSort Tbl

    For i = LBound(Tbl) To UBound(Tbl)
        For j = 2 To [B1].End(xlToRight).Column
            dicoTrie(Tbl(i)) = WorksheetFunction.Max(WorksheetFunction.CountIf(plage.Offset(0, j - 1), Tbl(i)), dicoTrie(Tbl(i)))
        Next
    Next i

    For Each Cle In dicoTrie.keys
        'Debug.Print Cle & " - " & dicoTrie(Cle)
    Next

    ici = 1
    Set cel1 = Rows(1).Find(What:="M", After:=Range("A1"), SearchDirection:=xlNext)
    For Each Cle In dicoTrie.keys
        If UCase(Mid(Cle, 1, 1)) = "M" Then
            cel1.Offset(ici, 0).Value = Mid(Cle, 2, Len(Cle) - 1)
            ici = ici + dicoTrie(Cle) + 1
        End If
    Next
    cel1.Offset(ici, 0).Value = "Fin de liste"

    ici = 1
    Set cel1 = Rows(1).Find(What:="A", After:=Range("A1"), SearchDirection:=xlNext)
    For Each Cle In dicoTrie.keys
        If UCase(Mid(Cle, 1, 1)) = "A" Then
            cel1.Offset(ici, 0).Value = Mid(Cle, 2, Len(Cle) - 1)
            ici = ici + dicoTrie(Cle) + 1
        End If
    Next
    cel1.Offset(ici, 0).Value = "Fin de liste"

    For i = 2 To [A2].End(xlDown).Row
        For j = 2 To [B1].End(xlToRight).Column

            Set cel1 = Rows(1).Find(What:=Mid(Cells(i, j), 1, 1), After:=Range("A1"), SearchDirection:=xlNext)
            Set cel2 = Rows(1).Find(What:=Cells(1, j), After:=cel1, SearchDirection:=xlNext)
            Set cel3 = Columns(cel1.Column).Find(What:=Mid(Cells(i, j), 2, Len(Cells(i, j)) - 1), After:=cel1, SearchDirection:=xlNext)

            plus = 0
            Do Until Cells(cel3.Row + plus, cel2.Column) = ""
                plus = plus + 1
            Loop
            Cells(cel3.Row + plus, cel2.Column) = Cells(i, 1)

        Next
    Next

End Sub

Public Sub QuickSort(vArray As Variant, _
  Optional ByVal inLow As Long = -1, _
  Optional ByVal inHi As Long = -1)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long
  inLow = IIf(inLow = -1, LBound(vArray), inLow)
  inHi = IIf(inHi = -1, UBound(vArray), inHi)
  tmpLow = inLow
  tmpHi = inHi
  pivot = vArray((inLow + inHi) \ 2)
  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend
     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend
     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend
  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

C'est avec une telle usina à gaz qu'on voit l'intérêt de PowerQuery proposé par Jean-Eric

11tseoy-v3bis.xlsm (22.42 Ko)
Le 01/10/2018 à 11:36

merci

c'est du grand art!

thierry

Le 08/10/2018 à 10:42

bonjour steelson,

après étude des différentes propositions, je vais tenter les formules.

Je n'arrive pas à adapter les macros proposées à un tableau fixe.

j'ai donc adapté (tenté ) la formule à mon fichier.

cependant je n'arrive pas à comprendre pourquoi ca ne se reincrémente pas.

merci de ton aide

thierry

4classeur1test.xlsx (52.00 Ko)
Le 08/10/2018 à 11:06

Ce sont des formules matricielles ... à valider par Ctrl+Maj+Entrée

6classeur1test.xlsx (71.38 Ko)
Le 08/10/2018 à 14:33

merci beaucoup;

c'est fonctionnel

bonne journee

thierry

Le 10/10/2018 à 10:57
3classeur1test.xlsx (93.85 Ko)

Bonjour STEELSON,

je reviens encore vers vous car sur mon fichier j'ai des cellules avec des * ici ligne 6 et 7.

ex: M1*

Les étoiles ne sont là que pour montrer un temps de travail différent des autres.

Mon fichier étant une extraction d'un fichier entreprise je ne peux changer ce fonctionnement.

comment faire pour que la formule ne tienne pas compte de cette étoile.

merci

Le 10/10/2018 à 11:20

en AU4 :

=SIERREUR(INDEX($A:$A;PETITE.VALEUR(SI(SUBSTITUE(DECALER($A$3;1;EQUIV(CB$3;$B$3:$AF$3;0);NBVAL($A:$A)-1);"*";"")=$AT$3&$AT$4;LIGNE(DECALER($A$3;1;EQUIV(CB$3;$B$3:$AF$3;0);NBVAL($A:$A)-1));9^9);LIGNE(AU4)-LIGNE($AT$4)+1));"")

à valider par Ctrl+Maj+Entrée

Rechercher des sujets similaires à "tri alphanumerique"