Trier avec plusieurs conditions

Le 25/11/2022 à 06:53
bonjour,

Je ne sais pas si c'est possible par VBA..

ma demande serait de trier à partir de la colonne B dans une base selon les critères début et de fin situé dans l'onglet "adresses"
6test1.xlsx (226.44 Ko)


puis dans chaque section :

- Le trie s'effectuerais selon la colonne "H" étages.

- De plus si l'étage est 0 trie déscendant par colonne "K" , si l'étage est 1 trie montant par colonne "K" etc jusqu'à 5 étages...

ci joint un fichier exemple avec un onglet résultat souhaité.
Le 25/11/2022 à 08:23

Bonjour,

Voir le fichier joint, en cliquant sur le bouton "Traitement des données" de la feuille1, le résultat s'affiche dans la feuille "Après_Traitement".

2yoda60-trier-avec-plusieurs-conditions.xlsm (241.20 Ko)

Le code

    Dim f1 As Worksheet, f2 As Worksheet, f3 As Worksheet
    Dim DerLig_f1 As Long, DerLig_f2 As Long, DerLig_f3 As Long, i As Long
    Dim Prem_Lig As Long, Der_Lig As Long
    Dim Deb As String, Der As String
    Dim Couleur_Fond As Long

 Sub Traitement()
    Après_Traitement
    Tri
 End Sub

Sub Après_Traitement()
    Set f1 = Sheets("Feuil1")
    Set f3 = Sheets("Après_Traitement")
    DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row
    f1.Range("A1:L" & DerLig_f1).Copy f3.Range("A1")
End Sub

Sub Tri()
    Set f2 = Sheets("adresses")
    Set f3 = Sheets("Après_Traitement")

    ' premier tri ascendant sur l'emplacement
    f3.Select
    DerLig_f3 = f3.Range("A" & Rows.Count).End(xlUp).Row
    f3.Range("A2:L" & DerLig_f3).Interior.ColorIndex = xlNone
    f3.Range("A2:L" & DerLig_f3).Font.ColorIndex = 1
    Range("A2:L" & DerLig_f3).Sort Range("B1"), 1

    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To DerLig_f2
        Couleur_Fond = f2.Cells(i, "A").Interior.Color
        'Relevé des adresses
        Deb = f2.Cells(i, "A") 'adresse de début
        Der = f2.Cells(i, "B") 'adresse de fin
         'repérage de la zone à traiter
        With f3.Range("B1:B" & DerLig_f3)
            Set D = .Find(Deb, lookat:=xlPart)
            If Not D Is Nothing Then
                Prem_Lig = D.Row
            Else
                MsgBox "Adresse de début introuvable"
                Exit Sub
            End If
            Set f = .Find(Der, lookat:=xlPart)
            If Not f Is Nothing Then
                Der_Lig = f.Row
            Else
                MsgBox "Adresse de fin introuvable"
                Exit Sub
            End If
        End With

        'Choix du sens du tri de la colonne "H"
        If i Mod 2 = 0 Then ord = 1 Else ord = 2
        'Tri en fonction de l'étage
        Range(f3.Cells(Prem_Lig, "A"), f3.Cells(Der_Lig, "L")).Sort Range("H" & Prem_Lig - 1), ord
        Range(f3.Cells(Prem_Lig, "A"), f3.Cells(Der_Lig, "L")).Interior.Color = Couleur_Fond
    Next i
    For i = 2 To DerLig_f3
        If f3.Cells(i, "H").Interior.ColorIndex <> xlNone Then
            If f3.Cells(i, "H") Mod 2 <> 0 Then Range(f3.Cells(i, "A"), f3.Cells(i, "L")).Font.ColorIndex = 3
        End If
    Next i
End Sub

Cdlt

Le 25/11/2022 à 21:46

bonjour et merci pour ce code.

quasi tout bon mais juste le tri descendant par étage impair par colonne K n'y ai pas.

" De plus si l'étage est 0 trie descendant par colonne "K" , si l'étage est 1 trie montant par colonne "K" etc jusqu'à 5 étages..."

le résultat de la macro est

image

et en fait apres A09A0900/C on repart sur E090901/C

donc plus qu'à trier les zones lignes en rouge par trie descendant par colone k.

si quelqu'un à la solution, merci d'avance

Le 26/11/2022 à 11:34

bonjour Arturo83, yoda60, le fil,

6test1-1.xlsb (223.92 Ko)
Sub teste()
     Dim aOut, aA, sp, i, j, Ptr, s, c
     With Sheets("Adresses")     'CREER UNE LISTE 1D DES CODES
          aA = .Range(.Range("C2"), .Range("D1").End(xlDown))     'ces codes
          s = "'" & WorksheetFunction.Rept("0", 8)     'code le plus petit
          For i = 1 To UBound(aA)     'boucle ces codes
               For j = 1 To 2
                    s = s & vbLf & aA(i, j)     'les 2 codes connu
               Next
               s = s & vbLf & Left(aA(i, 2), 4) & Format(Mid(aA(i, 2), 5) + 1, "0000")     'code de la 2ième colonne +1
               If i <> UBound(aA) Then
                    s = s & vbLf & Left(aA(i + 1, 1), 4) & Format(Mid(aA(i + 1, 1), 5) - 1, "0000")     'code de la prochaine ligne -1
               Else
                    s = s & vbLf & "ZZZZ9999"     'le plus grand code
               End If
          Next
          sp = Split(s, vbLf)     'split
          With .Range("F1").Resize(UBound(sp) + 1)     'écrire vers ici
               .Value = Application.Transpose(sp)
               .Name = "MesZones"     'plage nomée
          End With
     End With

     With Sheets("feuil1")
          Set c = .Range("A1").CurrentRegion     'vos données
          c.Cells(1, "M").Resize(c.Rows.Count).FormulaR1C1 = "=MATCH(RC[-11],MesZones,1)+RC[-5]/10"     'colonne supplémentaire avec une formule
          c.Cells(1, "M").Value = "MesZones"     'entête de cette colonne
          With .Range("A1:M1").Resize(c.Rows.Count)     'avec cette plage
               .Sort .Range("M1"), xlAscending, , .Range("B1"), xlAscending, Header:=xlYes  'trier la colonne M & B

               aA = .Columns("M").Value     'lire le contenu de M
               ReDim aOut(1 To UBound(aA), 1 To 3)     'diminsioner une matrice temporaire pour mémoriser les lignes
               Ptr = 1: aOut(1, 1) = aA(2, 1): aOut(1, 2) = 2     'initialiser 1ier ligne
               For i = 2 To UBound(aA)     'boucler
                    If aA(i, 1) <> aOut(Ptr, 1) Then     'changement de code ou d'étage
                         Ptr = Ptr + 1     'incrementer pointer
                         aOut(Ptr, 1) = aA(i, 1)     'code + etage
                         aOut(Ptr, 2) = i     'ligne de début
                         aOut(Ptr, 3) = UBound(aA)     'ligne de fin (temporaire)
                         If i <> 2 Then aOut(Ptr - 1, 3) = i - 1     'corriger ligne de fin temporaire précédente
                    End If
               Next

               For i = 1 To Ptr 'boucler les plages
                    With .Rows(aOut(i, 2)).Resize(aOut(i, 3) - aOut(i, 2) + 1) 'une plage
                         .Borders(xlInsideVertical).LineStyle = xlNone 'les bordures
                         .Borders(xlInsideHorizontal).LineStyle = xlNone
                         .Borders(xlEdgeTop).Weight = xlMedium
                         .Borders(xlEdgeBottom).Weight = xlMedium
                         .Sort .Range("K1"), IIf(.Range("H1").Value Mod 2, xlDescending, xlAscending), Header:=xlNo 'trier colonne K ascendant ou descendant dependant de l'étage
                    End With
               Next
          End With
      End With
End Sub
Le 26/11/2022 à 13:51

Bonjour,

Ma proposition corrigée

4yoda60-trier-avec-plusieurs-conditions-2.xlsm (242.98 Ko)

Question: Dans votre exemple de résultat souhaité, la partie en orange est-elle traitée correctement, car les étages ne sont pas triés comme demandés, ou alors je n'ai peut-être pas bien compris.

Cdlt

Le 26/11/2022 à 14:28

Bonjour Bart et Arthuro,

un grand merci à vous 2 pour les propositions.

Oui Arthuro et pardon , il faut traiter comme la partie verte , je n'ai pas été vigilant dans l'exemple.

Les solutions sont nickel !!!!!!!!!!

GRAND Merci

Le 26/11/2022 à 14:38

bonjour yoda60,

merci pour votre reaction. Je pense que si vous changer le tableau de la feuille "Adresses" en un colonne, ce serait beaucoup plus facile pour le code de Arturo84 et moi

image
Le 26/11/2022 à 17:44

la remarque est judicieuse, merci encore du coup de main!

bonne soirée

Rechercher des sujets similaires à "trier conditions"