Dédoublonnage impossible à optimiser

[Lexandre]

Bonjour,

Je fais du VBA depuis peu et je n'arrive pas optimiser mon code.

Je cherche à supprimer les doublons tout en gardant les différences entre les lignes de doublons. C'est à dire que les doublons ont tous 4 cases de différentes.

Lorsque je dédoublonne je récupère les 4 cases et je les mets à la fin du code. Cela fonctionne pour environ 200/300 lignes c'est assez rapide mais mon fchier fait presque 6000 lignes et là Excel plante et ne répond plus...

Sub Concatene()
Dim i As Integer, Id As Long
Dim e As Integer, y As Integer
     Sheets("Feuil1").Select
     For i = Range("A1").SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
       '  Id = LCase(Cells(i, 1).Value)
       Id = Cells(i, 1)
         'si Id différent de vide alors
         If Id > 0 Then
                  
             'Compare si autre ligne méme texte
             For e = i - 1 To 1 Step -1
      ' Debug.Print (Cells(e, 1))
                 'If LCase(Cells(e, 1)) = Id Then
                 If Cells(e, 1) = Id Then
                 'il y a un Doublon
                ' Debug.Print ("OK")
                           'on déplace les valeurs en L
                           Cells(e, 14) = Cells(i, 12)

                           'on déplace les valeurs en M
                           Cells(e, 15) = Cells(i, 13)
 
                     'Supprimé la ligne
                     Rows(i).Delete
                 End If
             Next e
         End If
     Next i
End Sub

 

[flyonets44]

Re : Dédoublonnage impossible à optimiser

Bonjour
pour optimiser la vitesse de traitement
mettre en début de macro ce code
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
et en fin de macro
Application.Calculation = xlCalculationautomatic
ci dessous du code à adapter
Sub Deleteif_findwordtrue()
'destruction selective de lignes contenant une occurence
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Quoi As String, Rng As Range, Frange As Range, C As Object, Lastrow&
Quoi = "TEST"
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = ActiveSheet.Range("A1:A" & Lastrow)
If Application.CountIf(Rng, Quoi) > 0 Then
For Each C In Rng
If UCase(C.Value) = Quoi Then
If Frange Is Nothing Then
'Set Frange = C.EntireRow
Set Frange = C(1, 1)
Else
' Frange= la plage des objets trouvés
' Set Frange = Union(Frange, C.EntireRow)
Set Frange = Union(Frange, C(1, 1))
End If
End If
Next
If Not Frange Is Nothing Then
Frange.Interior.ColorIndex = 36
Frange.Replace What:=Quoi, Replacement:="Ici", LookAt _
:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
'ou encore Frange.Delete
Set Frange = Nothing
End If
End If

Cordialement
Flyonets

Cordialement
Flyonets

 

[JCGL]

Re : Dédoublonnage impossible à optimiser

Bonjour à tous,


Si ton code te donne satisfaction et mise en application de la préconisation de Flyonets (un peu plus lisible) :

Option Explicit



Sub Concatene()
    Dim i As Integer, Id As Long
    Dim e As Integer, y As Integer


    With Application
        .ScreenUpdating = 0
        .Calculation = xlCalculationManual
    End With


    Sheets("Feuil1").Select
    For i = Range("A1").SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
        '  Id = LCase(Cells(i, 1).Value)
        Id = Cells(i, 1)
        'si Id différent de vide alors
        If Id > 0 Then


            'Compare si autre ligne méme texte
            For e = i - 1 To 1 Step -1
                ' Debug.Print (Cells(e, 1))
                'If LCase(Cells(e, 1)) = Id Then
                If Cells(e, 1) = Id Then
                    'il y a un Doublon
                    ' Debug.Print ("OK")
                    'on déplace les valeurs en L
                    Cells(e, 14) = Cells(i, 12)


                    'on déplace les valeurs en M
                    Cells(e, 15) = Cells(i, 13)


                    'Supprimé la ligne
                    Rows(i).Delete
                End If
            Next e
        End If
    Next i


    With Application
        .ScreenUpdating = 1
        .Calculation = xlCalculationAutomatic
    End With


End Sub

 

[Lexandre]

Re : Dédoublonnage impossible à optimiser

Merci à vous deux !

Je test tout ça et je vous dit 😉

 

[Lexandre]

Re : Dédoublonnage impossible à optimiser

Sub Concatene()
Dim i As Integer, Id As Long
Dim z As Integer
Dim e As Integer, y As Integer

    With Application
        .ScreenUpdating = 0
        .Calculation = xlCalculationManual
    End With


     Sheets("Feuil1").Select
     For i = Range("A1").SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
       '  Id = LCase(Cells(i, 1).Value)
       Id = Cells(i, 1)
         'si Id différent de vide alors
         If Id > 0 Then
                       
              z = 2
             'Compare si autre ligne méme texte
             For e = i - 1 To 1 Step -1
                 
                 If Cells(e, 1) = Id Then
                 'il y a un Doublon
                 
                           'on déplace les valeurs en L puis
                           Cells(e, 12 + z) = Cells(i, 12)
Debug.Print ("celulle i=" & Cells(i, 12))
Debug.Print ("Z=" & z)
Debug.Print ("I=" & i)
Debug.Print ("E=" & e)
Debug.Print ("-----------------")
                           'on déplace les valeurs en M
                           Cells(e, 13 + z) = Cells(i, 13)
                        z = z + 2

                     'Supprimé la ligne
                     Rows(i).Delete
                 End If
                 
             Next e
             
         End If
     Next i
          
    With Application
        .ScreenUpdating = 1
        .Calculation = xlCalculationAutomatic
    End With
     
End Sub

J'ai rajouté le code afin d'optimiser, effectivement ça ne plante plus, c'est lent mais ça marche. Merci.

En revanche j'ai un souci. Je peux avoir X fois le même ID donc N case à reporter, j'ai ajouté une variable z mais ça ne marche pas tout à fait. J'ai compris en parti le bug, lorsque je commente la ligne permettant la suppression de la ligne (Rows(i).delete) cela fonctionne sauf que j'ai tjrs mes doublons.

J'ai beau recoupé le pblm dans tous les sens, je ne trouve pas...

 

[winter]

Re : Dédoublonnage impossible à optimiser

Bonjour
Personnellement, je n'aurai pas fait de code compliqué pour dédoublonner, j'aurai simplement rajouté, à codé de ma clef à dédoublonner une colonne de calcul.
1) je suppose que j'ai une ligne de titres (mes données commencent en ligne 2)
2) la première colonne A:A contient la concaténation des zones sur lesquelles dédoublonner;
3) la deuxième colonne contient une formule qui s'appuiera sur cette colonne précédente:
Je tape la formule ci après dans la cellule B2 puis je la recopie vers le bas selon le nb de lignes dont j'ai besoin

Puis après, je crée un filtre sur la colonne B:B, et je supprime les lignes dont je ne veux pas.

Voici la formule à coller en B2:B2

=SI(A2="";"";NB.SI(A:A;A2)*SI(NB.SI(A$2:A2;A2)>1;0;1))

Si le résultat est 0, c'est que l'on a déja compté le code.
Si le résultat est supérieur est à 0 , c'est le nb de fois ou on l'a compté
Si le résultat est 1, c'est que le code est unique

ce qui veut dire

a) la somme de cette colonne est égale à la somme des lignes.
b) je peux m'appuyer sur ce résultat pour calculer par une exemple une autre colonne de chiffre d'affaire ou autre ...

(j'ai repris votre exemple)

Voila. Je ne sais pas si c'est très performant mais c'est simple et cela fonctionne très bien sur quelques milliers de lignes.

 

[ROGER2327]

Re : Dédoublonnage impossible à optimiser

Bonsoir à tous

Une autre méthode dans le classeur joint.
1. Mettre les données dans la feuille Feuil1.
2. Activer la feuille Feuil2.
​

ROGER2327
#6233

Samedi 28 Tatane 139 (Nativité de Saint Bruggie - fête Suprême Quarte)
23 Thermidor An CCXX, 9,5208h - lentille
2012-W32-5T22:51:00Z

 

[Lexandre]

Re : Dédoublonnage impossible à optimiser

Merci pour ton fichier ROGER2327 néanmoins j'ai un souci... je n'arrive pas déclarer une varibale de type Dictionnary comme tu l'as fait. Je débute en VBA et je n'arrive pas à la déclarer. Qaund j'utilise ton fichier ça marche mai si je fais un copier/coller ça ne marche plus. En lisant la doc, je n'ai pas trouvé comment faire. Peut être un pblm de private/public ?