Macro de tri et de déplacement de lignes

mj69008

XLDnaute Nouveau
Bonjour.

Je cherche depuis longtemps une macro pour faire un tri particulier mais impossible d'en trouver une qui corresponde à mon besoin. De plus, mon niveau en VBA est bien trop faible pour que je puisse en adapter une déjà existante.

J'ai mis un exemple en fichier joint qui sera beaucoup plus parlant qu'une longue explication pas claire.

Merci beaucoup par avance pour vos réponses:cool: .
 

Fichiers joints

MatiChoux

XLDnaute Occasionnel
Re : Macro de tri et de déplacement de lignes

Hello mj69008.

Je te propose la macro suivante - certes un peu complexe aux premiers abords - mais qui fonctionne. Je viens de la tester à l'instant.
Code:
Sub tri_reclassement()
  ' déclaration de deux variables pour compter
  ' les lignes en colonnes B et C
  Dim nbLignesColonneB As Integer
  Dim nbLignesColonneC As Integer
  Dim nbLignesEntree As Integer
  
  ' récupération de la dernière ligne utilisée en colonne B
  nbLignesColonneB = Range("B65536").End(xlUp).Row
  ' récupération de la dernière ligne utilisée en colonne C
  nbLignesColonneC = Range("C65536").End(xlUp).Row

  ' pour savoir où se situe la dernière ligne utilisée
  ' entre les colonnes B et C
  If nbLignesColonneB < nbLignesColonneC Then
     nbLignesEntree = nbLignesColonneC 
  ElseIf nbLignesColonneB > nbLignesColonneC Then
     nbLignesEntree = nbLignesColonneB 
  ElseIf nbLignesColonneB = nbLignesColonneC Then
     nbLignesEntree = nbLignesColonneB 
  End If
  
  ' déclaration d'un compteur pour indiquer
  ' sur quelle ligne écrire la prochaine valeur
  Dim delta As Integer
  delta = 2  ' initialisation à 2
  ' déclaration d'un sous-compteur si la valeur
  ' apparait plus d'une fois en colonne C
  Dim laps As Integer
  laps = 0
    
  ' déclaration de plusieurs variables utiles
  Dim plage As Range ' plage de cellules
  Dim collect As Collection ' collection de valeurs
  Dim tableau(500) As String ' tableau à 500 entrées
  
  ' instanciation de la plage : B2 jusqu'à Cx avec x étant
  ' la dernière ligne utilisée (entre les colonnes B et C)
  Set plage = Range("B2:C" & nbLignesEntree )
  Set collect = New Collection ' nouvelle collection
  
  Dim cel ' objet de scan
  ' boucle de scan de chaque cellule de la plage
  For Each cel In plage
     ' on ajoute la valeur de la cellule dans la collection
     On Error Resume Next
     collect.Add cel.Value, CStr(cel.Value)
  Next cel
  
  Dim tx As Integer
  ' boucle allant de 0 au nombre d'items dans la collection
  For tx = 0 To collect.Count
     ' remplissage du tableau avec les éléments de la collection
     ' le tableau est donc composé d'éléments uniques
     ' chaque valeur de cellule apparait en unique / pas de doublons
     tableau(tx) = Format(collect.Item(tx), "000")
     ' formatage de type 000 pour que le nombre 99 soit considéré comme 
     ' étant avant 100 ; sinon vu qu'alphabétiquement 9 > 1 : il serait après.
  Next tx
  
  ' tri du tableau dans l'ordre décroissant
  Dim valeur As Integer
  Dim i As Integer
  Dim cible As Variant
  Do
     valeur = 0
     For i = 0 To UBound(tableau) - 1
        If tableau(i) < tableau(i + 1) Then
           cible = tableau(i)
           tableau(i) = tableau(i + 1)
           tableau(i + 1) = cible
           valeur = 1
        End If
     Next i
  Loop While valeur = 1
  ' fin du tri du tableau dans l'ordre décroissant
    
  ' boucle allant du dernier élément du tableau au premier
  ' -> donc pour un affichage dans l'ordre croissant
  Dim z As Integer
  z = 2
  For i = UBound(tableau) To 0 Step -1
     ' si l'élément du tableau n'est pas vide
     If tableau(i) <> "" Then
        ' on stocke en colonne F le nombre de fois que l'élément du tableau apparait en colonne C
        Cells(z, 6).FormulaLocal = "=NB.SI(C2:C" & nbLignesColonneC & ";" & tableau(i) & ")"
        ' on stocke en colonne G le nombre de fois que l'élément du tableau apparait en colonne B
        Cells(z, 7).FormulaLocal = "=NB.SI(B2:B" & nbLignesColonneB & ";" & tableau(i) & ")"
        ' on incrémente z pour que la prochaine valeur soit écrite à la ligne suivante
        z = z + 1
     End If
  Next i
  
  ' on réinitialise z à la valeur 2
  z = 2
  For i = 2 To Range("F65536").End(xlUp).Row
    valTemporaire = Mid(Cells(z, 6).FormulaLocal, Len(Cells(z, 6).FormulaLocal) - 3, 3)
    ' si la valeur est uniquement en colonne B
    If Cells(z, 6).Value = 0 And Cells(z, 7).Value = 1 Then
       Cells(delta, 8).Value = valTemporaire
       Cells(delta, 9).Value = ""
       delta = delta + 1
    End If
       
    ' si la valeur est uniquement en colonne C
    If Cells(z, 6).Value >= 1 And Cells(z, 7).Value = 0 Then
       Cells(delta, 8).Value = ""
       Cells(delta, 9).Value = valTemporaire
       delta = delta + 1
    End If

    ' si la valeur est en colonne B et en colonne C
    If Cells(z, 6).Value = 1 And Cells(z, 7).Value = 1 Then
       Cells(delta, 8).Value = valTemporaire
       Cells(delta, 9).Value = valTemporaire
       delta = delta + 1
    End If
       
    ' si la valeur apparait une fois en colonne B et plusieurs fois en colonne C
     If Cells(z, 6).Value > 1 And Cells(z, 7).Value = 1 Then
        Cells(delta, 8).Value = valTemporaire
        For y = 1 To Cells(z, 6).Value
             Cells(delta + laps, 9).Value = valTemporaire
             laps = laps + 1
        Next y
        delta = delta + laps
        laps = 0
      End If
      z = z + 1
    Next i
    
  ' déclaration de deux variables pour compter
  ' les lignes en colonnes H et I
  Dim nbLignesColonneH As Integer
  Dim nbLignesColonneI As Integer
  Dim nbLignes As Integer
  
  ' récupération de la dernière ligne utilisée en colonne H
  nbLignesColonneH = Range("H65536").End(xlUp).Row
  ' récupération de la dernière ligne utilisée en colonne I
  nbLignesColonneI = Range("I65536").End(xlUp).Row
    
  If nbLignesColonneH < nbLignesColonneI Then
     nbLignes = nbLignesColonneI 
  ElseIf nbLignesColonneH > nbLignesColonneI Then
     nbLignes = nbLignesColonneH 
  ElseIf nbLignesColonneH = nbLignesColonneI Then
     nbLignes = nbLignesColonneH 
  End If
    
  For x = 2 To nbLignes
     If Left(Cells(x, 8).Value, 1) = ";" Then _
        Cells(x, 8).Value = Right(Cells(x, 8).Value, Len(Cells(x, 8).Value) - 1)
     If Left(Cells(x, 9).Value, 1) = ";" Then _
        Cells(x, 9).Value = Right(Cells(x, 9).Value, Len(Cells(x, 9).Value) - 1)
     
     ' condition d'affichage de "Libellé" et de "Montant"
     ' si les deux cellules en H et I ont la meme valeur
     ' OU
     ' si la cellule en H est vide et que la cellule en I est remplie
     ' alors on affiches "Libellé" et "Montant" dans les colonnes J et K adaptées
     If (Cells(x, 8).Value = Cells(x, 9).Value) Or (Cells(x, 8).Value = "" And Cells(x, 9).Value <> "") Then
         Cells(x, 10).Value = "Libellé"
         Cells(x, 11).Value = "Montant"
     End If
     
     ' nettoyage des cellules F et G stockant des valeurs temporaires
     Cells(x, 6).Value = ""
     Cells(x, 7).Value = ""
   Next x 
End Sub
Cela semble barbare mais j'ai essayé de commenter au maximum. ^^
En ce qui concerne l'algorithmique, j'ai suivi le raisonnement suivant : je déclare une plage de cellules correspondant à toutes les cellules que je souhaite classer. Je les stocke dans une collection pour les avoir de manière unique (sans doublons). Ensuite de la collection, je les passe dans un tableau qui se charge de les trier de façon décroissante. Je fais une boucle inverse - allant de la fin du tableau jusqu'au début - pour chaque élément contenu dans le tableau et non vide. Là je déroule l'algorithme des conditions, etc.
 
Dernière édition:

mj69008

XLDnaute Nouveau
Re : Macro de tri et de déplacement de lignes

Merci infiniment !!!:)

Je viens de trouver ta réponse à l'instant et d'essayer la macro. Elle marche super bien.

Juste un détail : la macro me donne en résultat toujours les valeurs "libellé" et "montant" alors que mes valeurs sont toutes différentes, ce qui donnerait par exemple :

862 862 Achat timbres 45
863 863 Frais réception 30
864 864 Achat MP 25

Est-ce possible de la modifier ?

Merci.
 

ROGER2327

XLDnaute Barbatruc
Re : Macro de tri et de déplacement de lignes

Bonsoir à tous.


Une autre proposition dans le classeur joint, avec ce code :​
VB:
Sub aaa()
'Nécessite l'ajout de la bibliothèque Microsoft Scripting Runtime au projet.
Dim i&, j&, k&, n&, u&, v(), w()
Dim Plg2 As Range, Plg1 As Range
Dim Table As New Scripting.Dictionary, Clef$, Clefs

'Paramètres:

    Set Plg1 = Me.Range("B2:E8") 'Plage de données

    Set Plg2 = Me.Range("H2") 'Cellule de destination
'____________________________________________________

'Création de la table d'index selon la structure :
'   Key = Clef (Une valeur de la première ou de la deuxième colonne de Plg1)
'   Item = {type, {nombre1, ligne(1), ligne(2), ..., ligne(nombre1)}, {nombre2, ligne(1), ligne(2), ..., ligne(nombre2)}}
'       type = 1 pour une clef ne figurant qu'en première colonne de Plg1
'       type = 2 pour une clef ne figurant qu'en deuxième colonne de Plg1
'       type = 3 pour une clef figurant dans les deux premières colonnes de Plg1
'       nombre1 = nombre d'occurrences de la clef dans la première colonne de Plg1
'       SI nombre1 > 0 : ligne(1), ligne(2), ..., ligne(nombre1) = numéros des lignes correspondantes dans Plg1
'       nombre2 = nombre d'occurrences de la clef dans la deuxième colonne de Plg1
'       SI nombre2 > 0 : ligne(1), ligne(2), ..., ligne(nombre1) = numéros des lignes correspondantes dans Plg1
'____________________________________________________

'   1. Clefs dans la première colonne de données :

    Table.CompareMode = BinaryCompare
    k = Plg1.Rows.Count
    For i = 1 To k
        Clef = Plg1(i, 1).Value
        If Clef <> "" Then
            If IsNumeric(Clef) Then Clef = Right$("              " & Clef, 15)
            If Table.Exists(Clef) Then
                v = Table(Clef)
                w = v(1)
                ReDim Preserve w(1 + UBound(w))
                w(0) = 1 + w(0)
                w(UBound(w)) = i
                v(1) = w
                Table(Clef) = v
            Else
                Table.Add Clef, Array(1, Array(1, i), Array(0))
            End If
        End If
    Next
'____________________________________________________

'   2. Clefs dans la deuxième colonne de données :

    For i = 1 To k
        Clef = Plg1(i, 2).Value
        If Clef <> "" Then
            If IsNumeric(Clef) Then Clef = Right$("              " & Clef, 15)
            If Table.Exists(Clef) Then
                v = Table(Clef)
                v(0) = 3
                w = v(2)
                ReDim Preserve w(1 + UBound(w))
                w(0) = 1 + w(0)
                w(UBound(w)) = i
                v(2) = w
                Table(Clef) = v
            Else
                Table.Add Clef, Array(2, Array(0), Array(1, i))
            End If
        End If
    Next
'____________________________________________________

'Table des Clefs en ordre croissant :

    Clefs = Table.Keys
    n = UBound(Clefs)
    For i = 0 To n - 1
        Clef = Clefs(i)
        u = 0
        For j = i + 1 To n
            If Clefs(j) < Clef Then u = j: Clef = Clefs(j)
        Next
        If u Then Clefs(u) = Clefs(i): Clefs(i) = Clef
    Next
'____________________________________________________

'Sortie des résultats :

    k = 0
    With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
    Plg2.Resize(Rows.Count - Plg2.Row, 4).Clear
    For i = 0 To n
        v = Table(Clefs(i))
        Select Case v(0)
        Case 1
            w = v(1)
            For j = 1 To w(0)
                Plg1.Rows(w(j)).Cells(1).Copy Destination:=Plg2.Offset(k)
                k = k + 1
            Next
        Case 2
            w = v(2)
            For j = 1 To w(0)
                Plg1.Rows(w(j)).Offset(, 1).Resize(1, 3).Copy Destination:=Plg2.Offset(k, 1)
                k = k + 1
            Next
        Case 3
            w = Array(v(1), v(2))
            u = (w(0)(0) + w(1)(0) + Abs(w(0)(0) - w(1)(0))) / 2
            For j = 1 To u
                If j <= w(0)(0) Then Plg1.Rows(w(0)(j)).Cells(1).Copy Destination:=Plg2.Offset(k)
                If j <= w(1)(0) Then Plg1.Rows(w(1)(j)).Offset(, 1).Resize(1, 3).Copy Destination:=Plg2.Offset(k, 1)
                k = k + 1
            Next
        End Select
    Next
    With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
'____________________________________________________

'Facultatif : ménage de printemps...

    Set Table = Nothing
    Set Plg1 = Nothing
    Set Plg2 = Nothing
    Erase v, w
'____________________________________________________

End Sub


ROGER2327
#6801


Mardi 24 Phalle 140 (Sainte Orchidée, aumonière - fête Suprême Quarte)
17 Fructidor An CCXXI, 9,7986h - cardière
2013-W36-2T23:31:00Z
 

Fichiers joints

Dernière édition:

ROGER2327

XLDnaute Barbatruc
Re : Macro de tri et de déplacement de lignes

Suite...


... avec une variante toutentableaux (beaucoup plus rapide) :​
VB:
Sub aaa()
'Nécessite l'ajout de la bibliothèque Microsoft Scripting Runtime au projet.
Dim i&, j&, k&, l&, n&, u&, s(), v(), w()
Dim Plg2 As Range, Plg1 As Range, Plg
Dim Table As New Scripting.Dictionary, Clef$, Clefs

'Paramètres:

    Set Plg1 = Me.Range("B2:E8") 'Plage de données

    Set Plg2 = Me.Range("H2") 'Cellule de destination
'____________________________________________________

    Plg = Plg1.Value
    Set Plg1 = Nothing
    k = UBound(Plg)
'____________________________________________________

'Création de la table d'index selon la structure :
'   Key = Clef (Une valeur de la première ou de la deuxième colonne de Plg1)
'   Item = {type, {nombre1, ligne(1), ligne(2), ..., ligne(nombre1)}, {nombre2, ligne(1), ligne(2), ..., ligne(nombre2)}}
'       type = 1 pour une clef ne figurant qu'en première colonne de Plg1
'       type = 2 pour une clef ne figurant qu'en deuxième colonne de Plg1
'       type = 3 pour une clef figurant dans les deux premières colonnes de Plg1
'       nombre1 = nombre d'occurrences de la clef dans la première colonne de Plg1
'       SI nombre1 > 0 : ligne(1), ligne(2), ..., ligne(nombre1) = numéros des lignes correspondantes dans Plg1
'       nombre2 = nombre d'occurrences de la clef dans la deuxième colonne de Plg1
'       SI nombre2 > 0 : ligne(1), ligne(2), ..., ligne(nombre1) = numéros des lignes correspondantes dans Plg1
'____________________________________________________

'   1. Clefs dans la première colonne de données :

    Table.CompareMode = BinaryCompare
    For i = 1 To k
        Clef = Plg(i, 1)
        If Clef <> "" Then
            If IsNumeric(Clef) Then Clef = Right$("              " & Clef, 15)
            If Table.Exists(Clef) Then
                v = Table(Clef)
                w = v(1)
                ReDim Preserve w(1 + UBound(w))
                w(0) = 1 + w(0)
                w(UBound(w)) = i
                v(1) = w
                Table(Clef) = v
            Else
                Table.Add Clef, Array(1, Array(1, i), Array(0))
            End If
            l = l + 1
        End If
    Next
'____________________________________________________

'   2. Clefs dans la deuxième colonne de données :

    For i = 1 To k
        Clef = Plg(i, 2)
        If Clef <> "" Then
            If IsNumeric(Clef) Then Clef = Right$("              " & Clef, 15)
            If Table.Exists(Clef) Then
                v = Table(Clef)
                v(0) = 3
                w = v(2)
                ReDim Preserve w(1 + UBound(w))
                w(0) = 1 + w(0)
                If v(1)(0) < w(0) Then l = l + 1
                w(UBound(w)) = i
                v(2) = w
                Table(Clef) = v
            Else
                Table.Add Clef, Array(2, Array(0), Array(1, i))
                l = l + 1
            End If
        End If
    Next
'____________________________________________________

'Table des Clefs en ordre croissant :

    Clefs = Table.Keys
    n = UBound(Clefs)
    For i = 0 To n - 1
        Clef = Clefs(i)
        u = 0
        For j = i + 1 To n
            If Clefs(j) < Clef Then u = j: Clef = Clefs(j)
        Next
        If u Then Clefs(u) = Clefs(i): Clefs(i) = Clef
    Next
'____________________________________________________

'Sortie des résultats :

    With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
    With Plg2
        .Resize(Rows.Count - Plg2.Row, 4).Clear
        If l Then
            ReDim s(1 To l, 1 To 4)
            k = 0
            For i = 0 To n
                v = Table(Clefs(i))
                Select Case v(0)
                Case 1
                    w = v(1)
                    For j = 1 To w(0)
                        k = k + 1
                        s(k, 1) = Plg(w(j), 1)
                    Next
                Case 2
                    w = v(2)
                    For j = 1 To w(0)
                        k = k + 1
                        For u = 2 To 4: s(k, u) = Plg(w(j), u): Next
                    Next
                Case 3
                    w = Array(v(1), v(2))
                    u = (w(0)(0) + w(1)(0) + Abs(w(0)(0) - w(1)(0))) / 2
                    For j = 1 To u
                        k = k + 1
                        If j <= w(0)(0) Then s(k, 1) = Plg(w(0)(j), 1)
                        If j <= w(1)(0) Then For u = 2 To 4: s(k, u) = Plg(w(1)(j), u): Next
                    Next
                End Select
            Next
            With .Resize(k, 4)
                .Value = s
                .Borders.LineStyle = xlContinuous
            End With
        End If
    End With
    With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
'____________________________________________________

'Facultatif : ménage de printemps...

    Set Table = Nothing
    Set Plg2 = Nothing
    Erase s, v, w
'____________________________________________________

End Sub


ROGER2327
#6802


Mercredi 25 Phalle 140 (Nativité apparente d’Artaud le Momo - fête Suprême Quarte)
18 Fructidor An CCXXI, 4,8958h - nerprun
2013-W36-3T11:45:00Z
 

Fichiers joints

Dernière édition:

mj69008

XLDnaute Nouveau
Re : Macro de tri et de déplacement de lignes

Merci beaucoup ROGER2327 pour cette macro également !:D

De plus :
- elle intègre bien le tri associé des valeurs "libellé" et "montant"
- le double-clic pour lancer la commande est très pratique.

Je suis ravi.
 

Discussions similaires


Haut Bas