XL 2013 Eclater 4 fichiers par macro

[nat54]

Bonjour,

Bien qu'ayant conservé d'anciennes macros réalisées notamment grâce à ce forum, je suis en galère d'où ma venue.

Le topo : je dispose de 4 fichiers Excel (extractions de Business Objects) dans lesquels j'ai les destinataires selon un code.
Les 4 fichiers suivent la même trame : les données commencent en B4 jusque Qxxx
--> EJ
--> chrono
--> SF
--> DP

Mon objectif : créer un fichier par destinataire avec 4 onglets (un onglet EJ, un chrono, un SF, un DP)
J'ai entre 10 et 12 destinataires : 1001, 1002 ...

J'ai anonymisé les 4 fichiers

Pourriez-vous svp m'aider ?

Un grand merci d'avance,

 

[Bernard_XLD]

Re,

sinon, voici le code modifié, le choix des fichiers sources s'ouvre par défaut dans le dossier du fichier contenant la macro et on peut aussi choisir le dossier de destination, dossier du classeur contenant la macro par défaut.
également le programme demande si il faut garder les fichiers ouverts après création

Bonne journée !
Bien cordialement, @+

Sub Traitement_Fichiers()
Dim x As Byte, y&, z%, Wbk() As Workbook, Wbk_Dest As Workbook, Der&, Chemin_Dossier_Dest$, RepC
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFilePicker)
    .ButtonName = "Lire"
    .AllowMultiSelect = True
    .Title = "Choisissez le fichier " & x
    .InitialFileName = ThisWorkbook.Path & "\*"
    .Filters.Clear
    .Filters.Add "Extraction données", "*.xlsm; *.xlsx", 1
    .Show
    If .SelectedItems.Count > 0 Then
        z = .SelectedItems.Count
        ReDim Wbk(1 To z)
        For x = 1 To z
            Set Wbk(x) = Workbooks.Open(Filename:=.SelectedItems(x))
        Next x
    Else
        Exit Sub
    End If
End With
Chemin_Dossier_Dest = ThisWorkbook.Path
If MsgBox("Enregistrer les fichiers dans " & Chemin_Dossier_Dest & Chr(10) & "( si non, sélectionner le dossier et bouton Choisir )", vbYesNo + vbQuestion) = vbNo Then
    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "choisir"
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Sélectionnez le dossier de destination"
        .Show
        If .SelectedItems.Count > 0 Then
            Chemin_Dossier_Dest = .SelectedItems(1)
        Else
            MsgBox "pas de dossier sélectionné" & Chr(10) & "Fin de l'édition", vbOKOnly + vbInformation
            GoTo Fin
        End If
    End With
End If
RepC = MsgBox("Garder les fichiers destinations ouverts après création", vbYesNo + vbQuestion)
For y = 1001 To 1012
    For x = 1 To z
        If x = 1 Then
            Wbk(x).Sheets(1).Copy
            Set Wbk_Dest = ActiveWorkbook
        Else
            Wbk(x).Sheets(1).Copy Before:=Wbk_Dest.Sheets(1)
        End If
        With ActiveSheet
            Der = .Range("B65536").End(xlUp).Row
            With .Range("B3:E3")
                .AutoFilter
                .AutoFilter Field:=1, Criteria1:="<>*" & y & "*"
            End With
            .Range("B4:B" & Der).EntireRow.SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
            .AutoFilterMode = False
            .Range("A1").Select
        End With
    Next x
    Wbk_Dest.SaveAs Filename:=Chemin_Dossier_Dest & "\" & "Dest " & y & " " & Format(Now(), "ddd dd mmm yyyy hh mm") & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    If RepC = vbNo Then Wbk_Dest.Close False
    DoEvents
Next y
MsgBox "Fichiers enregistrés dans le dossier " & Chemin_Dossier_Dest, vbOKOnly + vbInformation
Fin:
For x = 1 To z
    Wbk(x).Close False
Next x
Application.ScreenUpdating = True
End Sub