Autres Classement colonnes en VBA

Twisty

XLDnaute Nouveau
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.
 

Pièces jointes

  • 1.xls
    27 KB · Affichages: 19
Solution
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

XLDnaute Nouveau
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.
 

Pièces jointes

  • 1 essai.xls
    47.5 KB · Affichages: 7

job75

XLDnaute Barbatruc
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
 

Pièces jointes

  • 1 essai.xls
    56 KB · Affichages: 8

Twisty

XLDnaute Nouveau
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

XLDnaute Barbatruc
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+
 

Pièces jointes

  • 1 essai.xls
    56 KB · Affichages: 6

Twisty

XLDnaute Nouveau
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

XLDnaute Nouveau
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
 

Pièces jointes

  • Contrôle Véralec - Copie.xls
    110.5 KB · Affichages: 8

job75

XLDnaute Barbatruc
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+
 

Pièces jointes

  • Contrôle Véralec - Copie.xls
    121.5 KB · Affichages: 3
Dernière édition:

Twisty

XLDnaute Nouveau
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

XLDnaute Barbatruc
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
 

Pièces jointes

  • Contrôle Véralec - Copie.xls
    123 KB · Affichages: 9

Discussions similaires

Membres actuellement en ligne

Statistiques des forums

Discussions
313 322
Messages
2 097 140
Membres
106 850
dernier inscrit
benbeckman