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---...

hastaz

XLDnaute Nouveau
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+
Merci beaucoup, ceci fonctionne parfaitement.
 

Discussions similaires

Statistiques des forums

Discussions
315 138
Messages
2 116 664
Membres
112 829
dernier inscrit
Yozil10