Filtre sur VBA : Filtrer même si la valeur n'est pas présente
r
Bonjour à tous,
Je vous explique le problème, j'ai une macro qui doit extraire des données sur plein de fichiers (qui sont toujours les même) dans un dossier et parfois les filtres différent, je m'explique, le filtre Accepté sera présent quoi qu'il arrive mais le filtre Payé ou Prévu peuvent ne pas être présents, je voudrai que ma macro fonctionne même si ces filtres ne sont pas présent sur le fichier source.
Toute aide serait le bienvenue, Bien à vous :
Sub ExtractionTPE()
'Optimisation des erreurs
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Déclaration des variables
Dim wb As Workbook, wbs As Workbook
Dim ws As Worksheet, wss As Worksheet
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimisation de la vitesse de traitement
Application.ScreenUpdating = False
Application.EnableEvents = False
'Déclarer valeur aux variables
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Feuil1")
R1 = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
'Activation de l'explorateur de fichier windows
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'En cas d'erreur
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Prendre tout les fichiers qui ont l'extension .xls
myExtension = "*.xls*"
'Cibler chemin qu'on a donné + extension
myFile = Dir(myPath & myExtension)
cnt = 0
'Activation de la boucle avec tout les fichiers du dossier
Do While myFile <> ""
Set wbs = Workbooks.Open(Filename:=myPath & myFile)
Set wssR = wbs.Sheets(1) 'comme il y a un seul onglet dans le classeur
'Action à effectuer (copier/filtrer/coller)
DoEvents
Rs = wssR.Cells(Rows.Count, 1).End(xlUp).Row
R1 = ws.Cells(Rows.Count, 2).End(xlUp).Row + 1
Set Rng = wssR.Range("A2:Z" & Rs)
wssR.Range("A1").AutoFilter Field:=5, Criteria1:="=Accepté" _
, Operator:=xlOr, Criteria2:="=Prévu"
Range("R2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Selection.Copy
ws.Range("A" & R1).PasteSpecial
Application.CutCopyMode = False
'Fermer le fichier source sans sauvegarder
wbs.Close SaveChanges:=False
'Être sur que le fichier soit bien fermé
DoEvents
'Prochain fichier
myFile = Dir
Loop
'Message de fin de tâche
MsgBox "Fin de la tâche"
ResetSettings:
'Reactivation des paramêtre de macro
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub