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

job75 à dit:

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+

Cliquez pour agrandir...