Supprimer les montant en double

Salut
vraiment je voudrais votre aide à mon problème
j'ai un fichier Excel qui dépasse 580.000 lignes

et je voudrais bien supprimer les montant en double et les dossier = 0

j'explique

1- supprimer les dossiers qui ont un total Zéro
2- supprimer les montant ( + - ) en double et qui ont le même numéro du dossier

Merci d'avance pour votre aide.

Bonjour,

Voici un essai avec la référence de la plage à adapter.

Je n'ai pas regardé le fichier. Ici, le code suppose que les numéros de dossier sont en colonne 1 et les montants en colonne 8. Il faudra également adapter cela dans le code :

sub dedoublonner()
set dico = createobject("Scripting.dictionary")
with activesheet.range("plage") '<<< ADAPTER
    t = .value2
    for i = lbound(t) to ubound(t)
        if t(i, 8) <> 0 and not dico.exists(t(i, 1) & "_" & t(i, 8)) then '<<< ADAPTER
            n = n + 1
            dico(t(i, 1) & "_" & t(i, 8)) = "" '<<< ADAPTER
            for k = lbound(t, 2) to ubound(t, 2)
                t(n, k) = t(i, k)
            next k
        end if
    next i
    .clearcontents
    if n > 0 then .resize(n, ubound(t, 2)).value2 = t
end with
end sub

Je n'ai aucune idée du temps que l'exécution pourra prendre...

Cdlt,

Merci 3GB pour ton soutien

mais j'arrive pas à adapter la plage à mon fichier

mes salutations

Attention, je viens de faire des toutes petites modifs sur le code avant ta réponse donc il faudra le recopier pour essayer...

Et bien supposons que tes données soient en A1:H580000, il faut mettre dans le code (ligne 3) :

with activesheet.range("A1:H580000")

Puis, pour les colonnes, j'ai considéré que le dossier était en première colonne de la plage et le montant en 8è colonne. Mais ce n'est probablement pas le cas, alors il faudra que tu modifies le 1 (dans chaque t(i, 1)) par la position de la colonne avec les dossiers et le 8 (dans chaque t(i, 8)) par la position de la colonne avec les montants.

La seule incertitude, c'est que tu as parlé de total. Or, j'écarte seulement dossiers avec un montant égal à 0 pour l'instant, sans calculer le total. Me suis-je trompé ?

Mr 3GB je vous joindre un autre fichier sans filtre et j'aimerai bien

si possible que tu applique le VB directe sur mon fichier

paracerque je suis novis en xls et ton soutien m'aide énormément

D'accord, tu veux supprimer les écritures soldées si je comprends bien ?

Peux-tu poster un exemple plus "réel", car j'aurai besoin d'un champ avec des valeurs uniques, le code opération peut-être...

Et je ne comprends pas ces montants négatifs ? Soit on a que des montants positifs, soit tous les montants négatifs sont rattachés à D et tous les montants positifs sont rattachés à C.

Cdlt,

tu veux supprimer les écritures soldées si je comprends bien ? oui

ça veut dire lorsque je totalise tout les montant négatifs ET positifs ( - + )
de la colonne Mvts et qui ont le même numéro du dossier
et nous donne un total 0 je supprime tout

et le 2 cas
supprimer les valeur ( - + ) qui ont le même montant et le même numéro dossier

Voici un nouvel essai :

Sub dedoublonner()

Application.Calculation = xlCalculationManual
Set dico = CreateObject("Scripting.dictionary")
With ActiveSheet.UsedRange
    t = .Value2
    ReDim temp(1 To UBound(t, 2))
    For i = LBound(t) To UBound(t)
        solde = Application.SumIf(.Columns(11), t(i, 11), .Columns(14))
        If solde <> 0 Then
            cle = t(i, 11) & "_" & Abs(t(i, 14))
            If Not dico.exists(cle) Then '<<< ADAPTER
                For k = LBound(temp) To UBound(temp)
                    temp(k) = t(i, k)
                Next k
                dico(cle) = temp
            Else
                dico.Remove cle
            End If
        End If
    Next i
    .ClearContents
    If dico.Count > 0 Then .Resize(dico.Count, UBound(t, 2)).Value2 = Application.Transpose(Application.Transpose(dico.items))
End With
Application.Calculation = xlCalculationAutomatic

End Sub

Je ne suis pas sûr qu'il réponde en totalité au besoin...

Cdlt,

Merci 3GB pour la solution

après l’exécution du vb sur mon fichier qui contient presque 61985 lignes

il a supprimer 54.295 ligne

mais le total de la colonne 14 a donné un montant erroné

merci pour votre soutien

et j’attends TJR votre aide

Salut ninos,

Ca y est, je pense que ce code sera concluant :

Sub dedoublonner()

Application.Calculation = xlCalculationManual
Set wf = WorksheetFunction
Set dico = CreateObject("Scripting.dictionary")
With ActiveSheet.Range("A2:P28") '<<<<<<<<<<<<<< ADAPTER REF DE LA PLAGE
    t = .Value2
    ReDim temp(1 To UBound(t, 2))
    For i = LBound(t) To UBound(t)
        solde = wf.SumIf(.Columns(11), t(i, 11), .Columns(14))
        If solde <> 0 Then
            cle = Join(Array(t(i, 11), IIf(t(i, 14) < 0, "D", "C"), _
                wf.CountIfs(.Columns(11).Resize(i), t(i, 11), .Columns(14).Resize(i), t(i, 14)), t(i, 14)), "_")
            cleinv = Join(Array(t(i, 11), IIf(t(i, 14) < 0, "C", "D"), _
                wf.CountIfs(.Columns(11).Resize(i), t(i, 11), .Columns(14).Resize(i), t(i, 14)), -t(i, 14)), "_")
            If Not dico.exists(cleinv) Then
                For k = LBound(temp) To UBound(temp)
                    temp(k) = t(i, k)
                Next k
                dico(cle) = temp
            Else
                dico.Remove cleinv
            End If
        End If
    Next i
    .ClearContents
    If dico.Count > 0 Then .Resize(dico.Count, UBound(t, 2)).Value2 = wf.Transpose(wf.Transpose(dico.items))
End With
Application.Calculation = xlCalculationAutomatic

End Sub

Celui-ci ne supprime que les lignes du montant opposé...

Je joins le fichier qui a servi à faire les tests mais c'est bien ce code qu'il faut utiliser à partir de la feuille contenant la base de données. Il faudra juste adapter la plage !

Bonjour 3GB, ninos066

Pas testé, n'ayant pas VBA sous la main.

J'ai surligné pour bien visualiser le problème posé.

Option Explicit
Sub test()
Dim a, i As Long, x As Range, e
    With Sheets("Sheet2").Cells(1).CurrentRegion
        .EntireRow.Interior.ColorIndex = xlNone
        a = .Value
        With CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(a, 1)
                'colonne N
                If a(i, 14) > 0 Then
                     'colonne K
                    If Not .exists(a(i, 11)) Then
                        Set .Item(a(i, 11)) = CreateObject("Scripting.Dictionary")
                    End If
                    .Item(a(i, 11))(i) = a(i, 14)
                End If
            Next
            For i = 2 To UBound(a, 1)
                'colonne N
                If a(i, 14) < 0 Then
                    If .exists(a(i, 11)) Then
                        For Each e In .Item(a(i, 11)).keys
                            If a(i, 14) + .Item(a(i, 11))(e) = 0 Then
                                If x Is Nothing Then
                                    Set x = Union(Rows(i), Rows(e))
                                Else
                                    Set x = Union(x, Rows(e), Rows(i))
                                End If
                                .Item(a(i, 11)).Remove e: Exit For
                            End If
                        Next
                    End If
                End If
            Next
        End With
        'If Not x Is Nothing Then x.EntireRow.Delete 'supprime
        'colorie
        If Not x Is Nothing Then x.EntireRow.Interior.ColorIndex = 42
    End With
End Sub

klin89