Autres Classement colonnes en VBA

Twisty · 16 Mars 2024

Bonjour les ami(e)s,
Voilà mon problème , je souhaiterai que ma colonne D se classe par rapport à la colonne A , à cellule identique.
Mon problème, que je n'arrive pas à résoudre, c'est que chaque cellule de la colonne D , ainsi que les cellules E et F se positionnent aussi.
Et si dans ma colonne D , il n'y a aucune cellule identique se trouvant dans la colonne A , elles puissent se classer en fin de classement.
J'ai surligné en jaune les deux lignes non référencé en colonne A
Je vous remercie déjà par avance de toute l'aide que vous pourrez m'apporter.

job75 · 21 Mars 2024

Ce n'est pas fini, en utilisant un tableau VBA la macro s'exécute en 0,15 seconde :

VB:

Sub Classement()
Dim derlig&, d As Object, n&, x$, tablo, lig&
derlig = Cells.SpecialCells(xlCellTypeLastCell).Row
Application.ScreenUpdating = False
Range("A3:C" & derlig).Sort [A3], xlAscending, Header:=xlNo 'tri
Range("D3:F" & derlig).Sort [D3], xlAscending, Header:=xlNo 'tri
Doublons Range("A3:C" & derlig), 3
Doublons Range("D3:F" & derlig), 3
'---liste des numéros de lignes---
Set d = CreateObject("Scripting.Dictionary")
For n = 3 To derlig
    x = CStr(Cells(n, 1))
    If x <> "" Then d(x) = n 'mémorise le numéro de ligne
Next n
'---remises en place dans le tableau D E F---
ReDim tablo(1 To derlig - 2, 1 To 3) 'tableau VBA vide (plus...

Twisty · 18 Mars 2024

Bonjour job,
Excellent pour les doublons ...
Par contre je viens de remarquer que si il y a un gencod en moins en colonne D , le classement ne se fait plus du moins sur les dernières lignes.
Je m'explique , au lieu d'avoir sur la ligne d'un gencod en colonne A , mais non présent en C , donc une ligne vide sur D,E,F , le classement se remonte sans prendre en compte cette erreur , le classement est décalé.
Avez vous une solution pour ce petit problème , s'il vous plait.

Twisty · 18 Mars 2024

Je vous ai joint un fichier modifié pour que vous puissiez comprendre mon problème

job75 · 18 Mars 2024

Oui ça ne va plus du tout, les codes EAN ne se correspondent plus.

Désolé mais faute d'idées je laisse tomber.

job75 · 18 Mars 2024

Eh bien j'ai eu des idées :

- d'abord convertir en textes les codes EAN en A8 D25 et D26

- ensuite trier les 2 tableaux sur les colonnes A et D :

VB:

Sub Classement()
Dim derlig&, n&, i As Variant
derlig = Application.Max(Application.CountA(Columns(1)), Application.CountA(Columns(4))) + 1
Application.ScreenUpdating = False
Range("A3:C" & derlig - 1).Sort [A3], xlAscending, Header:=xlNo 'tri
Range("D3:F" & derlig - 1).Sort [D3], xlAscending, Header:=xlNo 'tri
Doublons Range("A3:C" & derlig - 1), 3
Doublons Range("D3:F" & derlig - 1), 3
For n = 3 To derlig - 1
    If Cells(n, 4) <> "" Then
        i = Application.Match(Cells(n, 4), Columns(1), 0)
        If IsError(i) Then
            Cells(n, 4).Resize(, 3).Cut Cells(derlig, 4) 'couper-coller
            derlig = derlig + 1
        ElseIf i <> n Then
            Cells(n, 4).Resize(, 3).Cut
            Cells(i - (i = n + 1), 4).Insert xlDown
        End If
    End If
Next
'---supprime les lignes entièrement vides---
For n = derlig - 1 To 3 Step -1
    If Application.CountA(Rows(n)) = 0 Then Rows(n).Delete
Next
End Sub

Sub Doublons(plage As Range, col%)
Dim d As Object, i&, x$
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To plage.Rows.Count
    x = plage(i, 1)
    If x <> "" Then
        If d.exists(x) Then
            plage(d(x), col) = plage(d(x), col) + plage(i, col)
        Else
            d(x) = i 'mémorise la ligne
        End If
    End If
Next
plage.RemoveDuplicates 1, Header:=xlNo 'supprime les lignes en doublon
End Sub

Twisty · 18 Mars 2024

Bonsoir job ou plutôt Maestro...
Vous m'avez rendu un très grand service , grâce à vous je vais gagner 1 h de travail par jour.
Cela va me permettre de rester un peu plus longtemps à la machine à café avec les copains...
C'est exactement un prog miracle
Merci beaucoup pour votre gentillesse et je vous souhaite une agréable soirée.

job75 · 19 Mars 2024

Bonjour Twisty, le forum,

Avec le fichier précédent ça ne va pas si on exécute une 2ème fois la macro.

C'est dû au calcul de derlig avec les cellules vides.

Prenez ce fichier, il faut utiliser :

VB:

derlig = Cells.SpecialCells(xlCellTypeLastCell).Row + 1

A+

Twisty · 19 Mars 2024

Bonjour Job,
Oui , il est à présent opérationnel... Yessss. Je l'essaye dès demain au travail.
Il est vraiment agréable d'avoir de gentilles personnes comme vous , pour nous venir en aide.
Merci beaucoup Job
Amicalement
Twisty

Twisty · 20 Mars 2024

Bonsoir job,
J'ai l'impression que si il y a trop de lignes , le fichier s'affole ...
Avant ma prise de poste , je dois réaliser une trentaine de fichiers comme celui-ci.
Je vous joins un original , voir si vous pouvez me trouver une solution ?
Bonne soirée et encore merci

job75 · 21 Mars 2024

Bonjour Twisty, le forum,

Bon j'ai pris le taureau par les cornes et modifié complètement la méthode :

VB:

Sub Classement()
Dim derlig&, d As Object, n&, x$, lig&
derlig = Cells.SpecialCells(xlCellTypeLastCell).Row
Application.ScreenUpdating = False
Range("A3:C" & derlig).Sort [A3], xlAscending, Header:=xlNo 'tri
Range("D3:F" & derlig).Sort [D3], xlAscending, Header:=xlNo 'tri
Doublons Range("A3:C" & derlig), 3
Doublons Range("D3:F" & derlig), 3
'---liste des numéros de lignes---
Set d = CreateObject("Scripting.Dictionary")
For n = 3 To derlig
    x = CStr(Cells(n, 1))
    If x <> "" Then d(x) = n 'mémorise le numéro de ligne
Next n
'---déplacement du 2ème tableau--
[G:I].Insert 'insère 3 colonnes auxiliaires
Range("D3:F" & derlig).Cut [G3]
'---remises en place dans le tableau D E F---
lig = derlig + 1
For n = 3 To derlig
    x = CStr(Cells(n, 7))
    If x <> "" Then
        If d.exists(x) Then
            Cells(n, 7).Resize(, 3).Cut Cells(d(x), 4) 'sur la bonne ligne
        Else
            Cells(n, 7).Resize(, 3).Cut Cells(lig, 4) 'sous le tableau
            lig = lig + 1
        End If
    End If
Next n
[G:I].Delete 'supprime les colonnes auxiliaires
'---supprime les lignes entièrement vides---
For n = derlig To 3 Step -1
    If Application.CountA(Rows(n)) Then Exit For
    Rows(n).Delete
Next n
End Sub

Sub Doublons(plage As Range, col%)
Dim d As Object, i&, x$
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To plage.Rows.Count
    x = plage(i, 1)
    If x <> "" Then
        If d.exists(x) Then
            plage(d(x), col) = plage(d(x), col) + plage(i, col)
        Else
            d(x) = i 'mémorise la ligne
        End If
    End If
Next
plage.RemoveDuplicates 1, Header:=xlNo 'supprime les lignes en doublon
End Sub

La macro s'exécute en 1,8 seconde chez moi, 18 lignes doublons sont supprimées.

A+

job75 · 21 Mars 2024

J'ai modifié la macro précédente, elle est un peu plus rapide.

Twisty · 21 Mars 2024

Bonjour job,
Oui ça fonctionne du feu de dieu . C'est tout simplement génial...
Merci beaucoup job , pour votre temps consacré à ce foutu prog. Mais grâce à vous , ce fichier Excel est devenu l'outil indispensable dans mon travail.
Un très grand merci et surtout très reconnaissant de votre patience.
Amicalement
Twisty

job75 · 21 Mars 2024

Ce n'est pas fini, en utilisant un tableau VBA la macro s'exécute en 0,15 seconde :

VB:

Sub Classement()
Dim derlig&, d As Object, n&, x$, tablo, lig&
derlig = Cells.SpecialCells(xlCellTypeLastCell).Row
Application.ScreenUpdating = False
Range("A3:C" & derlig).Sort [A3], xlAscending, Header:=xlNo 'tri
Range("D3:F" & derlig).Sort [D3], xlAscending, Header:=xlNo 'tri
Doublons Range("A3:C" & derlig), 3
Doublons Range("D3:F" & derlig), 3
'---liste des numéros de lignes---
Set d = CreateObject("Scripting.Dictionary")
For n = 3 To derlig
    x = CStr(Cells(n, 1))
    If x <> "" Then d(x) = n 'mémorise le numéro de ligne
Next n
'---remises en place dans le tableau D E F---
ReDim tablo(1 To derlig - 2, 1 To 3) 'tableau VBA vide (plus rapide)
lig = derlig + 1
For n = 3 To derlig
    x = CStr(Cells(n, 4))
    If x <> "" Then
        If d.exists(x) Then
            tablo(d(x) - 2, 1) = Cells(n, 4)
            tablo(d(x) - 2, 2) = Cells(n, 5)
            tablo(d(x) - 2, 3) = Cells(n, 6)
        Else
            Cells(n, 4).Resize(, 3).Copy Cells(lig, 4) 'sous le tableau
            lig = lig + 1
        End If
    End If
Next n
[D:D].NumberFormat = "@" 'format Texte
Range("D3:F" & derlig) = tablo 'restitution
Range("F3:F" & derlig).Interior.ColorIndex = xlNone 'RAZ
On Error Resume Next 'si aucune SpecialCell
Range("F3:F" & derlig).SpecialCells(xlCellTypeConstants).Interior.Color = RGB(204, 255, 204) 'vert
'---supprime les lignes entièrement vides---
For n = derlig To 3 Step -1
    If Application.CountA(Rows(n)) Then Exit For
    Rows(n).Delete
Next n
End Sub

Sub Doublons(plage As Range, col%)
Dim d As Object, i&, x$
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To plage.Rows.Count
    x = plage(i, 1)
    If x <> "" Then
        If d.exists(x) Then
            plage(d(x), col) = plage(d(x), col) + plage(i, col)
        Else
            d(x) = i 'mémorise la ligne
        End If
    End If
Next
plage.RemoveDuplicates 1, Header:=xlNo 'supprime les lignes en doublon
End Sub

Twisty · 22 Mars 2024

Bonsoir job,
Ce fichier Excel est redoutable...
Merci et encore Merci

Autres Classement colonnes en VBA

Twisty

XLDnaute Nouveau

Pièces jointes

job75

Twisty

XLDnaute Nouveau

Pièces jointes

Twisty

XLDnaute Nouveau

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

Twisty

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

Twisty

XLDnaute Nouveau

Twisty

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Twisty

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

Twisty

XLDnaute Nouveau

Discussions similaires