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

hastaz

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
job75
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---...
Trier par date Trier par votes
Robert

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
Vote positif 0 Vote négatif
job75

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: 4
  • fichier1.xlsx
    11.5 KB · Affichages: 3
  • fichier2.xlsx
    11.7 KB · Affichages: 2
Vote positif 0 Vote négatif
hastaz

hastaz

XLDnaute Nouveau
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...
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.
 
Vote positif 0 Vote négatif
hastaz

hastaz

XLDnaute Nouveau
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...
Bonsoir Job75,
Votre macro répond parfaitement à mon besoin. Je vous remercie infiniment.
 
Vote positif 0 Vote négatif
hastaz

hastaz

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

hastaz

XLDnaute Nouveau
hastaz à dit:
Bonsoir Job75,
Votre macro répond parfaitement à mon besoin. Je vous remercie infiniment.
Cliquez pour agrandir...
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.
 
Vote positif 0 Vote négatif
Robert

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.
Cliquez pour agrandir...
@ 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...
 
Vote positif 0 Vote négatif
Lone-wolf

Lone-wolf

XLDnaute Barbatruc
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...
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.
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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...
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
Vote positif 0 Vote négatif
job75

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
Vote positif 1 Vote négatif
Solution

Discussions similaires

N
  • Résolu(e)
XL pour MAC Erreur à l'enregistrement de plusieurs fichiers Excel
Réponses
5
Affichages
117
Noymie
N
jeanmi
  • Résolu(e)
XL 2013 recherche de données sur plusieurs fichiers
Réponses
13
Affichages
370
dysorthographie
dysorthographie
Q
  • Question
XL 2019 vba pour effacer résultat cellules de plusieurs fichiers a partir d'un fichier distant
Réponses
6
Affichages
148
Phil69970
Phil69970
vgendron
  • Question
Power Query [Resolu] Importer plusieurs fichiers excel provenant de dossiers différents sur sharepoint
Réponses
6
Affichages
939
Staple1600
Staple1600
edgy63
  • Question
Microsoft 365 Remplir cellules à partir de plusieurs fichiers Excel d'un dossier
2
Réponses
17
Affichages
424
alexga78
A
M
  • Question
XL 2021 Creation VBA copie de differents fichiers dans différents dossiers
Réponses
5
Affichages
326
patricktoulon
patricktoulon
jeff1494
  • Question
XL 2021 Liste des propriétés de fichiers.
3 4 5
Réponses
73
Affichages
3 K
jeff1494
jeff1494
C
  • Question
Microsoft 365 Extraction de datas dans des fichiers pdf
Réponses
2
Affichages
474
kiki29
kiki29
R
  • Question
XL 2021 Récupérer des données dans plusieurs classeurs sans les ouvrir - Résolu
Réponses
10
Affichages
408
job75
job75
J
  • Question
Microsoft 365 Conversion de fichiers word en pdf / VBA
Réponses
1
Affichages
395
kiki29
kiki29

Membres actuellement en ligne

8 membres et 71 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 611
Messages
2 111 146
Membres
111 051
dernier inscrit
MANUREVALAND