XL 2016 supprimer des données de plusieurs fichiers Excel VBA

Robert à dit:

Bonjour Hastaz, bonjour le forum,

En pièce jointe ton fichier modifié avec le code ci-dessous :

VB:

Sub ThauTheme()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TS As Variant 'déclare la variable TS (Tableau Source)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TD As Variant 'déclare la variable TD (Tableau Destination)
Dim I1 As Integer 'déclare la variable I1 (Incrément 1)
Dim I2 As Integer 'déclare la variable I2 (Incrément 2)
Dim PL As Range 'déclare la variable PL (PLAge)

Application.ScreenUpdating = fasle 'masque les rafraîchissements d'écran
Set CS = ThisWorkbook 'définit le classeur source CS
CA = CS.Path & "\" 'définit le chemin d'accès CA
Set OS = CS.Worksheets("Feuil1") 'définit l'onglet source OS
TS = OS.Range("A1").CurrentRegion 'définit le tableau source TS
F = Dir(CA & "*.xlsx") 'définit le premier fichier F ayant l'extension xlsx et CA comme chemin d'accès
Do 'execute
    Set PL = Nothing 'initialise la plage PL
    If F <> CS.Name Then 'condition si F ne porte pas le nom du classeur source
        Set CD = Workbooks.Open(CA & F) 'définit le classeur destination CD en l'ouvrant
        Set OD = CD.Worksheets(1) 'définit l'onglet destination OD
        TD = OD.Range("A1").CurrentRegion 'définit le tableau destination TD
    End If 'fin de la condition
    For I1 = 2 To UBound(TS, 1) 'boucle 1 : sur toutes les lignes I1 du tableau source TS (en partant de la seconde)
        For I2 = 2 To UBound(TD, 1) 'boucle 2 : sur toutes les lignes I2 du tableau destination TD (en partant de la seconde)
            'condition : si les données (remises dans l'ordre) correspondent
            If TS(I1, 1) = TD(I2, 1) And TS(I1, 2) = TD(I2, 3) And TS(I1, 3) = TD(I2, 4) And TS(I1, 4) = TD(I2, 2) Then
                'définit la plage PL (la ligne I2 de l'onglet OD si PL est vide sinon l'union de PL et de la ligne I2 de l'onglet OD)
                If PL Is Nothing Then Set PL = OD.Rows(I2) Else Set PL = Application.Union(PL, OD.Rows(I2))
            End If 'fin de la condition
        Next I2 'prochaine ligne de la boucle 2
    Next I1 'prochaine ligne de la boucle 1
    If Not PL Is Nothing Then PL.Delete 'si PL n'est pas vide, supprime la plage PL
    CD.Close True 'ferme le classeur destination en enregistrant les modifications
    F = Dir 'définit le prochain fichier F ayant l'extension xlsx et CA comme chemin d'accès
Loop Until F <> "" 'boucle tant qu'il existe de fichier F
Application.ScreenUpdating = fasle 'affiche les rafraîchissements d'écran
End Sub

Le fichier :

Cliquez pour agrandir...

job75 à dit:

Bonjour hastaz, bienvenue sur XLD, salut Robert,

Téléchargez les fichiers joints dans le même dossier (le bureau).

Ouvrez le fichier .xlsm et exécutez la macro du bouton :

VB:

Sub Rejet()
Dim t#, chemin$, fichier$, d As Object, i&, n%, nn&, x$, mes$
t = Timer
chemin = ThisWorkbook.Path & "\" 'dossier à adapter éventuellement
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Set d = CreateObject("Scripting.Dictionary")
'---préparation---
Application.ScreenUpdating = False
With ActiveSheet.UsedRange.Resize(, 4)
    .Sort .Rows(1), xlAscending, Header:=xlNo, Orientation:=xlLeftToRight 'tri horizontal des en-têtes
    .Columns.AutoFit 'ajuste les largeurs
    For i = 2 To .Rows.Count
        d(.Cells(i, 1) & Chr(1) & .Cells(i, 2) & Chr(1) & .Cells(i, 3) & Chr(1) & .Cells(i, 4)) = ""
    Next i
End With
'---traitement des fichiers---
While fichier <> ""
    With Workbooks.Open(chemin & fichier).Sheets(1)
        n = n + 1
        With .UsedRange.Resize(, 4)
            .Sort .Rows(1), xlAscending, Header:=xlNo, Orientation:=xlLeftToRight 'tri horizontal des en-têtes
            .Columns.AutoFit 'ajuste les largeurs
            nn = 0
            For i = .Rows.Count To 2 Step -1
                x = .Cells(i, 1) & Chr(1) & .Cells(i, 2) & Chr(1) & .Cells(i, 3) & Chr(1) & .Cells(i, 4)
                If d.exists(x) Then .Rows(i).EntireRow.Delete: nn = nn + 1 'supprime la ligne
            Next i
        End With
        mes = mes & vbLf & .Parent.Name & vbTab & nn 'avec caractère de tabulation
        .Parent.Close True 'enregistre et ferme le fichier
    End With
    fichier = Dir 'fichier suivant
Wend
MsgBox n & " fichiers traités en " & Format(Timer - t, "0.00 \sec") & vbLf & vbLf & "Nombre de lignes supprimées :" & vbLf & mes, , "Rejet"
End Sub

Nota : du fait qu'on est obligé d'ouvrir les fichiers et que cela prend du temps je n'ai pas jugé nécessaire d'utiliser une méthode plus rapide pour la suppression des lignes.

A+

Cliquez pour agrandir...

Lone-wolf à dit:

Bonsoir Job75, Robert, hastaz, le Forum.

Loin de moi à offenser les experts en vba, ne serait-il pas plus simple d'utiliser la méthode ADO, vu qu'elle a l'avantage d'être rapide et sans obligation d'ouvrir les fichiers?

EDIT: Suppression Enregistrement. Un lien intéressant, mais pour un seul fichier.

Cliquez pour agrandir...

hastaz à dit:

Bonsoir Job75,
Votre macro répond parfaitement à mon besoin. Je vous remercie infiniment.

Cliquez pour agrandir...

merci beaucoup pour votre aide. Sauf erreur de ma part, j'ai essayé d'exécuter la macro mais rien ne se passe.

Cliquez pour agrandir...

Robert à dit:

Bonsoir le fil, bonsoir le forum,


@ Hastaz
En effet il y avait une erreur. Il faut remplacer Loop Until... par Loop While... à la fin. Seul le fichier 1 était traité.

@Lone-wolf
Pas offensé juste boulé... Trop vieux pour utiliser la méthode ADO. Je trouve un peu facile de critiquer sans proposer de solution...

Cliquez pour agrandir...

hastaz à dit:

je souhaiterai supprimer toutes les lignes correspondantes aux numéros perso présents dans le fichier de rejet de tous les autres fichiers présent du même répertoire ainsi que leurs doublons. Je voudrai que le critère de suppression se fasse uniquement sur le critère du numéro perso.

Cliquez pour agrandir...

Sub Rejet()
Dim t#, chemin$, fichier$, d As Object, i&, n%, nn&, mes$
t = Timer
chemin = ThisWorkbook.Path & "\" 'dossier à adapter éventuellement
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Set d = CreateObject("Scripting.Dictionary")
'---préparation---
Application.ScreenUpdating = False
With ActiveSheet.UsedRange.Resize(, 4)
    .Sort .Rows(1), xlAscending, Header:=xlNo, Orientation:=xlLeftToRight 'tri horizontal des en-têtes
    .Columns.AutoFit 'ajuste les largeurs
    For i = 2 To .Rows.Count
        d(CStr(.Cells(i, 3))) = "" 'Numéro perso uniquement en 3ème colonne
    Next i
End With
'---traitement des fichiers---
While fichier <> ""
    With Workbooks.Open(chemin & fichier).Sheets(1)
        n = n + 1
        With .UsedRange.Resize(, 4)
            .Sort .Rows(1), xlAscending, Header:=xlNo, Orientation:=xlLeftToRight 'tri horizontal des en-têtes
            .Columns.AutoFit 'ajuste les largeurs
            nn = 0
            For i = .Rows.Count To 2 Step -1
                If d.exists(CStr(.Cells(i, 3))) Then .Rows(i).EntireRow.Delete: nn = nn + 1 'supprime la ligne
            Next i
        End With
        mes = mes & vbLf & .Parent.Name & vbTab & nn 'avec caractère de tabulation
        .Parent.Close True 'enregistre et ferme le fichier
    End With
    fichier = Dir 'fichier suivant
Wend
MsgBox n & " fichiers traités en " & Format(Timer - t, "0.00 \sec") & vbLf & vbLf & "Nombre de lignes supprimées :" & vbLf & mes, , "Rejet"
End Sub

Lone-wolf à dit:

Loin de moi à offenser les experts en vba, ne serait-il pas plus simple d'utiliser la méthode ADO, vu qu'elle a l'avantage d'être rapide et sans obligation d'ouvrir les fichiers?

Cliquez pour agrandir...

hélas je ne peux être d'aucune aide.

Cliquez pour agrandir...