Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

iliess

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

Pièces jointes

  • Piece et sont anulation.xlsx
    12 KB · Affichages: 7

iliess

XLDnaute Occasionnel
voila une autre solution

Code:
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

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

Code:
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
 

Pièces jointes

  • Piece et sont anulation V2.xlsm
    21.2 KB · Affichages: 5
Dernière édition:

Wayki

XLDnaute Impliqué
Bonjour,
J'ai retravaillé ce code qui marche chez moi :
VB:
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 +
 
Dernière édition:

iliess

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

VB:
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

XLDnaute Impliqué
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 :
VB:
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

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

XLDnaute Impliqué
É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

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

VB:
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

XLDnaute Impliqué
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

XLDnaute Occasionnel
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
VB:
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
 
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…