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