XL 2019 Supprimer la pièce et sont annulation en VBA

[iliess]

Bonjour
je suis un comptable et parfois j'ai fais des annulation des pièces comptable
mon objectif de supprimer la pièce original et la pièce annuler.
je vous explique
mon grand livre se compose de 8 colonne et 400000 ligne ou plus (un ficher volumineux) la colonne F c'est le libelle
si une pièce est annuler ou contre passe ce caractère "-C_" figure dans le libelle de la pièce contre passe mené avec le numéro de la pièce original.
un exemple

pièce original
journal N°PIECE LIBELLE
ACH 0000005 12547-achat matériel de construction Fac 12/2021
pièce contre passe ou annuler
ACH 0000045 12547-C_0000005 achat matériel de construction Fac 12/2021

donc la pièce ACH 0000045 est l'annulation de la pièce ACH 0000005

Svp comment supprimer les deux pièce
au début j'ai utiliser cette fonction =SI(SIERREUR(CHERCHE("*-C_*";F3);"")=1;C3&STXT(F3;CHERCHE("-C_";F3)+3;7);C3&D3).
mais je n'est pas pu travailler en vba

 

[iliess]

j'ai oublier le filtre "Oui" dans la colonne "I" et la suppression de tous les ligne qui contient "Oui"

 

[iliess]

est ce que je peux mettre ce code dans les tableaux ou dictionnaire.

 

[iliess]

voila une autre solution

Sub test1()
Dim Arr
Dim Dern As Long, Clé1 As String, Clé2 As String
Dim Sh As Worksheet
Set Sh = ThisWorkbook.Worksheets("Feuil1")
Dern = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row

j = 2
For i = 2 To Dern
    
    If Range("F" & i).Value Like "*-C_*" Then
             Range("L" & j).Value = Range("C" & i).Value
             Range("M" & j).Value = "=mid(F" & i & ",search(""-C_"",F" & i & ")+3,7)"
             Range("L" & j + 1).Value = Range("C" & i).Value
             Range("M" & j + 1).Value = "'" & Range("D" & i).Value
    j = j + 2
    End If

Next i
End Sub

en suite j'utilise le filtre avance et supprimer le résultat
demain je vous montre le code final

 

[Jacky67]

Re
voila les amis le code il est lent vu le nombre de ligne mais il est très efficace

RE...
Que donne celui-ci
Limite du nombre en filtre sur xl2019 ?????

Sub Supprimer()
    Dim Derlg&
    Application.ScreenUpdating = False
    With Feuil1
        .AutoFilterMode = False
        .Columns("I:K").Insert
        Derlg = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        .Range("i3:i" & Derlg).Formula = "=c3&d3"
        .Range("j3:j" & Derlg).Formula = "=IF(ISNUMBER(MID(F3,FIND(""-C_"",F3)+3,7)*1),C3&MID(F3,FIND(""-C_"",F3)+3,7),"""")"
        .Range("k3:k" & Derlg).Formula = "=COUNTIF($i$3:$I$" & Derlg & ",$J3)+COUNTIF($j$3:$J$" & Derlg & ",$I3)"
        On Error Resume Next    'rien à filtrer
        .Range("a2:k" & Derlg).AutoFilter Field:=11, Criteria1:=">0"
        .Range("a2:h" & Derlg).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .Columns("I:K").Delete
        .[a2].AutoFilter
    End With
End Sub

 

[Wayki]

Bonjour,
J'ai retravaillé ce code qui marche chez moi :

Sub test1()
Dim f As Long, num As Long
f = Range("F" & Rows.Count).End(xlUp).Row
Dim Tablo()
ReDim Tablo(0)
num = 0
For i = 2 To f

    If Range("F" & i) Like "*-C_*" Then
    On Error Resume Next
        If Tablo(num - 1) <> Split(Range("F" & i), "_")(1) Then
        Tablo(num) = Split(Range("F" & i), "_")(1)
        num = num + 1
        ReDim Preserve Tablo(num)
        End If
    End If
Next i
For t = LBound(Tablo) To UBound(Tablo) - 1
    For j = f To 2 Step -1
    If Range("I" & j) Like "ACH" & Tablo(t) & "*" Then Range("I" & j).EntireRow.Delete
    Next j
Next t


End Sub

Pas de tri, il devrait être assez performant, je l'exécute en moins de 1/10eme de secondes sur les quelques lignes de l'exemple avec un pc pas très performant.

A +

 

[iliess]

bonjour
Merci les amis les deux méthode sont bon
Pour 14539 Ligne t=63,99609
Mr @Wayki svp j'ai une autre idée peux être plus rapide

cette partie de votre code alimente le Tablo

If Range("F" & i) Like "*-C_*" Then
    On Error Resume Next
        If Tablo(num - 1) <> Split(Range("F" & i), "_")(1) Then
            Tablo(num) = Split(Range("F" & i), "_")(1)
            num = num + 1
            ReDim Preserve Tablo(num)
        End If
End If

svp comment ajouter même la valeur de la colonne D
exemple

0000045 12547-C_0000005 achat matériel de construction Fac 12/2021

tablo(0) = 0000005
tablo(1) = 0000045

apres je colle le tablo dans la colonne M et avec un filtre avance je filtre les piece du tablo et les supprimer

 

[Wayki]

Il y a eu un problème de postage visiblement car j'ai retravaillé le code afin qu'il cherche toute la référence ACH0000002 si son libellé comporte -C_
Voici le code :

Dim f As Long, num As Long
f = Range("F" & Rows.Count).End(xlUp).Row
Dim Tablo()
ReDim Tablo(0, 1)
num = 0
For i = 2 To f

    If Range("F" & i) Like "*-C_*" Then
    On Error Resume Next
        If Tablo(num - 1, 1) <> Split(Range("F" & i), "_")(1) And Tablo(num - 1, 0) <> Range("F" & i).Offset(0, -3) Then
        Tablo(num, 0) = Range("F" & i).Offset(0, -3)
        Tablo(num, 1) = Split(Range("F" & i), "_")(1)
        num = num + 1
        ReDim Preserve Tablo(num)
        End If
    End If
Next i
For t = LBound(Tablo) To UBound(Tablo)
    For j = f To 2 Step -1
    If Range("I" & j) Like Tablo(t, 0) & Tablo(t, 1) & "*" Then Range("I" & j).EntireRow.Delete
    Next j
Next t

Range("F" & i).Offset(0, -3) correspond à la colonne D
Dans l'exemple qui nous a été donné, le code supprime toutes les lignes de la colonne I qui ont ACH0000002.
Le problème de vos filtres c'est que sur des fichiers très volumineux, ils vont vous prendre beaucoup de mémoire et donc beaucoup de temps d'exécution.
A +

 

[iliess]

bonsoir Mr @Wayki
merci pour votre temps et votre effort pour m'aider et Mr @Jacky67 aussi

c'est un joli travail mais le Tablo ne se préserve pas il garde que deux valeur apres la boucle

si vous voulez je peux vous envoyer le fichier original au priver car c'est un document officiel et je ne peux pas publier dans les forums

 

[Wayki]

Étrange,
Si vous avez cette constatation par rapport à votre espion c'est normal.
Imaginez un tableau à 2 colonnes, a1 correspondrait à Tablo(0, 0), a2 à Tablo(1, 0) et B1 à Tablo(0, 1).
À combien est la valeur de UBound ?
Peut être un soucis avec ReDim, j'ai galère avec cette fonction...
Je ferais des tests plus poussés dès que je pourrais (le Lundi est compliqué pour moi, beaucoup de travail)
A +

 

[iliess]

Je ferais des tests plus poussés dès que je pourrais (le Lundi est compliqué pour moi, beaucoup de travail)
A +

Mille merci Mr
j'ai trouver la manière de remplir le Tablo avec tous les pièces que je doit les supprimer mais mon Tablo contient des doublons

For i = 18 To f

    If Range("F" & i) Like "*-C_*" Then
    On Error Resume Next
        Tablo(num) = Split(Range("F" & i), "_")(1)
        num = num + 1
        ReDim Preserve Tablo(num)
        
        Tablo(num) = Range("D" & i)
        num = num + 1
        ReDim Preserve Tablo(num)
        
        
    End If
Next i

je vais cherché de mon coter cette semaine
prenez tous votre temps je ne suis pas percés
merci encore une fois

 

[Wayki]

Mille merci Mr
j'ai trouver la manière de remplir le Tablo avec tous les pièces que je doit les supprimer mais mon Tablo contient des doublons

For i = 18 To f

    If Range("F" & i) Like "*-C_*" Then
    On Error Resume Next
        Tablo(num) = Split(Range("F" & i), "_")(1)
        num = num + 1
        ReDim Preserve Tablo(num)
       
        Tablo(num) = Range("D" & i)
        num = num + 1
        ReDim Preserve Tablo(num)
       
       
    End If
Next i

Regarde la pièce jointe 1121541


je vais cherché de mon coter cette semaine
prenez tous votre temps je ne suis pas percés
merci encore une fois

Oui j'avais fais ça à la base mais ça fait un tableau à 1 dimension il manque le code à 3 lettres.
En soit on peut l'incrémenter dans un tableau à 1 dimension avec le signe &.
Sinon reprenez mon code précédent, virez les redim et déclarer dim Tablo(f, 1).
La suite du code devrait fonctionner.
Par contre effectivement ça n'empêchera pas les doublons, j'y ai pensé mais que pour la ligne précédente. À réfléchir.
A +

 

[iliess]

Oui je vais essayé demain car maintenant je suis très fatigué.
je cherche a ajouter un dictionnaire qui évite les doublons.
bonne nuit
A+

 

[iliess]

Je ne pouvais pas m'endormir jusqu'à ce que j'aie trouvé la bonne solution
et voila ma surprise
une liste sans doublons et qui contient les ligne a supprimer

Sub tbrfv()
Dim arr
Dim f As Long, num As Long
dern = Range("F" & Rows.Count).End(xlUp).Row
Set d = CreateObject("Scripting.Dictionary")
arr = Range("A3:H" & dern)

For i = LBound(arr) To UBound(arr)
    
     If arr(i, 6) Like "*-C_*" Then
        Cle1 = arr(i, 3) & Split(arr(i, 6), "_")(1)
        Cle2 = arr(i, 3) & arr(i, 4)
            If Not d.exists(Cle1) And Not d.exists(Cle2) Then
                d.Add Cle1, Cle1
                d.Add Cle2, Cle2
            End If
     End If
        
Next i

End Sub

bonne nuit