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

hastaz

XLDnaute Nouveau
Bonjour,
Je suis novice en VBA et actuellement je travaille sur un nettoyage de data. J'ai à ma disposition un fichier nommé Rejet, comportant des données rejetés que je dois supprimer de 30 fichiers se situant dans un même répertoire. Le critère de suppression se fait sur la colonne "Numéro perso". Est ce quelqu'un peut m'aider?
Merci d'avance.
En pièce jointe un exemple de jeu de données.
 

Pièces jointes

  • fichier_REJET.xlsx
    11.3 KB · Affichages: 6
  • fichier1.xlsx
    11.3 KB · Affichages: 4
  • fichier2.xlsx
    11.5 KB · Affichages: 5
Solution
Bonjour hastaz, le forum,

Au lieu du tri horizontal on peut simplement rechercher la colonne "Numéro perso", fichier (3) :
VB:
Sub Rejet()
Dim t#, chemin$, fichier$, d As Object, col As Variant, 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---
With ActiveSheet.UsedRange.Resize(, 4)
    col = Application.Match("Numéro perso*", .Rows(1), 0)
    If IsError(col) Then MsgBox "Numéro perso non trouvé !", 48: Exit Sub
    For i = 2 To .Rows.Count
        d(CStr(.Cells(i, col))) = "" 'Numéro perso uniquement
    Next i
End With
'---traitement des fichiers---...

Robert

XLDnaute Barbatruc
Repose en paix
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 :
 

Pièces jointes

  • Hastaz_ED_v01.xlsm
    21.6 KB · Affichages: 2

job75

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

Pièces jointes

  • fichier_REJET(1).xlsm
    23.4 KB · Affichages: 3
  • fichier1.xlsx
    11.5 KB · Affichages: 2
  • fichier2.xlsx
    11.7 KB · Affichages: 2

hastaz

XLDnaute Nouveau
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 :
Bonsoir Robert,
merci beaucoup pour votre aide. Sauf erreur de ma part, j'ai essayé d'exécuter la macro mais rien ne se passe.
 

hastaz

XLDnaute Nouveau
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+
Bonsoir Job75,
Votre macro répond parfaitement à mon besoin. Je vous remercie infiniment.
 

hastaz

XLDnaute Nouveau
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.
Bonsoir Lone-wolf,
Je n'ai jamais entendu parler de cette méthode. Merci de l'avoir partager, je jetterai un œil dessus :)
 

hastaz

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

après divers tests de votre VBA, je m'aperçois qu'il y a toujours des données qui sont censées être supprimées du fichier 1 et 2 car présentes dans le fichiers de rejet. Comme je travaille sur une reprise de donnée, 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. Pourriez vous m'aider s'il vous plait.

merci d'avance.
 

Robert

XLDnaute Barbatruc
Repose en paix
Bonsoir le fil, bonsoir le forum,

merci beaucoup pour votre aide. Sauf erreur de ma part, j'ai essayé d'exécuter la macro mais rien ne se passe.
@ 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...
 

Lone-wolf

XLDnaute Barbatruc
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...
Bonsoir Robert,

je n'ai offensé personne, qu'est-ce que tu raconte. C'était juste une question que je posais, c'est tout. :rolleyes:
La proposition je l'ai faite avec le lien que j'ai mis au poste, et comme ça fait très longtemps que ne fais plus de programmation, hélas je ne peux être d'aucune aide.
 

job75

XLDnaute Barbatruc
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.
Dans ce cas pourquoi avoir mis 4 colonnes de critères dans le fichier de rejet ?

Mais bon, ma macro du post #3 supprime 9 lignes dans fichier1.xlsx et 14 lignes dans fichier2.xlsx.

Cette macro du fichier (2) en supprime 12 lignes et 17 lignes :
VB:
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
 

Pièces jointes

  • fichier_REJET(2).xlsm
    23.2 KB · Affichages: 3
  • fichier1.xlsx
    11.5 KB · Affichages: 4
  • fichier2.xlsx
    11.7 KB · Affichages: 3

job75

XLDnaute Barbatruc
Bonjour hastaz, le forum,

Au lieu du tri horizontal on peut simplement rechercher la colonne "Numéro perso", fichier (3) :
VB:
Sub Rejet()
Dim t#, chemin$, fichier$, d As Object, col As Variant, 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---
With ActiveSheet.UsedRange.Resize(, 4)
    col = Application.Match("Numéro perso*", .Rows(1), 0)
    If IsError(col) Then MsgBox "Numéro perso non trouvé !", 48: Exit Sub
    For i = 2 To .Rows.Count
        d(CStr(.Cells(i, col))) = "" 'Numéro perso uniquement
    Next i
End With
'---traitement des fichiers---
Application.ScreenUpdating = False
While fichier <> ""
    With Workbooks.Open(chemin & fichier)
        n = n + 1
        With .Sheets(1).UsedRange.Resize(, 4)
            col = Application.Match("Numéro perso*", .Rows(1), 0)
            If IsNumeric(col) Then
                nn = 0
                For i = .Rows.Count To 2 Step -1
                    If d.exists(CStr(.Cells(i, col))) Then .Rows(i).EntireRow.Delete: nn = nn + 1 'supprime la ligne
                Next i
            End If
        End With
        mes = mes & vbLf & .Name & vbTab & IIf(IsError(col), "Numéro perso non trouvé !", nn) 'avec caractère de tabulation
        .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
A+
 

Pièces jointes

  • fichier_REJET(3).xlsm
    23.6 KB · Affichages: 2
  • fichier1.xlsx
    11.5 KB · Affichages: 1
  • fichier2.xlsx
    11.7 KB · Affichages: 1

Discussions similaires

Réponses
5
Affichages
335
Compte Supprimé 979
C