VBA pour effacer les lignes en double

ci-joint un fichier qui contient plus de 3000 lignes

et je voudrais effacer les lignes qui est en double selon conditions

même Cpte et Chapitre

mais a condition que sens doit être un D et C

merci d'avance pour votre aide

Vraiment j'ai besoins de votre soutien

mes salutations

Salut,

Un essai dans le fichier ci-joint.

Si tu cliques sur le bouton en place, toutes les lignes superflues sont effacées.

A la fin du travail, pour la feuille en place, le total des lignes restantes (M166=SOMME(M2:M165)) est identique au total avant le nettoyage (M3150=SOMME(M2:M3149).

Cordialement.

merci pour ta solution

normalement c'est le résultat que je cherche

Mr Yvouille

j'ai un petit problème dans le programme VB que vous m'avez envoyer

notamment dans la ligne 05 :

For i = 2 To Range("A" & Rows.Count).End(xlUp).Row

le fichier contient presque 500 000 ligne

merci de m'aider une 2 fois

Salut,

Je ne sais pas ce que tu entends par ligne 05. En réalité la ligne 5 est vide.

Je présume que le problème vient du fait que tu as plus de 32768 lignes, donc mes variables déclarées en Integer sont dépassée.

A la ligne 4 , remplace les deux déclarations Integer par Long et ça devrait jouer.

Si non, fourni moi une copie d'écran de la ligne qui bloque (en jaune lorsque tu ouvres le débogueur).

Dans ton tout premier message tu as écrit : ci-joint un fichier qui contient plus de 3000 lignes.

Cordialement.

Bjr Mr : Yvouille

ca marche j'ai remplace les deux déclarations Integer par Long

mai tellement le fichier et gros elle prend beaucoup de temps

ya pas une solution pour accéléré l'exécution du VB

et merci d'avance

Combien est-ce beaucoup de temps pour toi ? Dois-tu effectuer ce travail très souvent ?

ll y aurait éventuellement une solution en passant par des tableaux. Je vais voir ça d'ici quelques jours. Si tu pouvais répondre à mes demandes ci-dessus entre temps, tant mieux.

Amicalement.

Salut Mr : Yvouille

oui Mr : Yvouille ca prend beaucoup de temps et ca fait plus de 2h et pas de résultat

ce travail je doit le finaliser dans les meilleurs délais

je compte Mr Yvouille sur votre aide

merci pour votre attention

Je serais intéressé à faire un essai moi-même. Tu peux me fournir ton fichier en privé ?

Salut Ninos,
Salut Yvouille,

on est bien d'accord que seules les colonnes [D-E] doivent être identiques avec, en [M:M]
- "C" et un nombre positif ;
- "D" et ce même nombre négatif

Un double-clic sur la feuille '1999' démarre la macro..

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tTab, sgRefD!, lgRefE&, lgRowD&, lgRowE1&, lgRowE2&, lgRowKC&, lgRowKD&
'
Cancel = True
With Worksheets("Extract")
    .Cells.Delete
    [A1].CurrentRegion.Copy Destination:=.[A1]
    .Columns.AutoFit
    .[A1].CurrentRegion.Sort key1:=.[M2], order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
    .[A1].CurrentRegion.Sort key1:=.[D2], order1:=xlAscending, key2:=.[E2], order2:=xlAscending, _
        key3:=.[K2], order3:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
    tTab = .Range("A1").Resize(.UsedRange.Rows.Count + 1, .UsedRange.Columns.Count).Value
    lgRowD = .Columns("K").Find(what:="C", lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Row
    sgRefD = CSng(tTab(lgRowD, 4))
    lgRefE = CLng(tTab(lgRowD, 5))
    '
    For x = lgRowD To UBound(tTab, 1)
        If CSng(tTab(x, 4)) = sgRefD And CLng(tTab(x, 5)) = lgRefE Then
            If tTab(x, 11) = "C" Then lgRowKC = x
            If tTab(x, 11) = "D" Then lgRowKD = x
        Else
            If lgRowKC > 0 And lgRowKD > 0 Then
                For y = lgRowD To lgRowKC
                    For Z = lgRowKC + 1 To lgRowKD
                        If tTab(Z, 1) <> "" And Abs(CDbl(tTab(Z, 13))) = CDbl(tTab(y, 13)) Then _
                            tTab(y, 1) = "": _
                            tTab(Z, 1) = "": _
                            Exit For
                    Next
                Next
            End If
            lgRowD = x
            sgRefD = CSng(tTab(x, 4))
            lgRefE = CLng(tTab(x, 5))
            lgRowKC = 0
            lgRowKD = 0
            x = lgRowD - 1
        End If
    Next
    .[A1].Resize(UBound(tTab, 1), 1).Value = tTab
    .Range("A1:A" & Range("B" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete shift:=xlUp
    .[A1].CurrentRegion.Sort key1:=.[D2], order1:=xlAscending, key2:=.[E2], order2:=xlAscending, _
        key3:=.[N2], order3:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
    .Activate
    Set tTab = Nothing
End With
'
End Sub

A+