Autres Classement colonnes en VBA

[Twisty]

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.

 

[Twisty]

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]

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

 

[job75]

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]

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 :

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]

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]

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 :

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

A+

 

[Twisty]

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]

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]

Bonjour Twisty, le forum,

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

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]

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

 

[Twisty]

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]

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

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]

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