Re : VBA boite de dialogue macro filtre
Voici la macro que j'ai fais j'ai un message d'erreur qui de m'affiche meme pas ma boite de dialogue .deja pouvez vous verifier si la macro est juste. je vous vous met en fichier joint mes fichiers.
Sub AP()
'Variables Declaration
Dim Path As String, File As String
Dim Worksheet As Worksheet
Dim Target_Worksheet As String
Dim OK_Worksheet As Boolean, Start As Boolean
Dim Name As Name
Dim FirstLine As Long, LastLine As Long, LastLineTarget As Long
Dim FirstColumn As Long, LastColumn As Long
Target_Worksheet = "Sheet1"
ThisWorkbook.Sheets(Target_Worksheet).Cells.Clear
Path = ThisWorkbook.Path
Start = True
'If unsaved file, then no path => always save the file before executing the macro
If Path <> "" Then
'Filters only on Excel files
File = Dir(Path & "\*.*xls*")
'Only "esthetic" : improves speed and processing appearance (deactivating sreen update)
Application.ScreenUpdating = False
Do While File <> ""
If File <> ThisWorkbook.Name Then
Workbooks.Open Filename:=Path & "\" & File, ReadOnly:=True, UpdateLinks:=False
Application.DisplayAlerts = False
'Test if worksheet exists
OK_Worksheet = False
For Each Worksheet In Workbooks(File).Sheets
If Worksheet.Name = Target_Worksheet Then OK_Worksheet = True: Exit For
Next
'If worksheet OK => copies worksheet content to "AP" file
If OK_Worksheet Then
Worksheet.Unprotect Password:="FCII"
Worksheet.Columns.Ungroup
Worksheet.AutoFilterMode = False
'Sets the range to copy in "AP"
FirstLine = LookforPeriod(Workbooks(File), Target_Worksheet) + 1
If Not Start Then FirstLine = FirstLine + 1
Start = False
LastLine = LookforLastline(Workbooks(File), Target_Worksheet)
FirstColumn = LookforFirstColumn(Workbooks(File), Target_Worksheet)
LastColumn = LookforLastColumn(Workbooks(File), Target_Worksheet)
LastLineTarget = LookforLastline(ThisWorkbook, "Sheet1") + 1
'No copy of the header if not the first file copied
With Workbooks(File).Sheets(Target_Worksheet)
.Range(.Cells(FirstLine, FirstColumn).Address & ":" & .Cells(LastLine, LastColumn).Address).Copy Destination:=ThisWorkbook.Sheets("Actual HC ERC").Range("A" & LastLineTarget)
End With
'Deletes named cells
For Each Name In ThisWorkbook.Names
Name.Delete
Next
Start = False
End If
Worksheet.Protect Password:="FCII"
Workbooks(File).Close False
End If
File = Dir
Loop
'Breaks Links
Dim Link As Variant
For Each Link In ActiveWorkbook.LinkSources
ActiveWorkbook.BreakLink Name:=Link, Type:=1
Next
'Deletes Data/Validation
Sheets("Sheet1").Select
Cells.Validation.Delete
'Deletes Conditional Formatting
Sheets("Sheet1").Select
Cells.FormatConditions.Delete
'Sorts data by Period
Cells.Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range( _
"Period"), SortOn:=xlSortOnValues, Order:=xlSelectedperiod, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Rows("1:01048576")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Filters
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.AutoFilter
Sheets("Updates").Select
' Re-activates Display Alerts
Application.DisplayAlerts = True
' Re-activates screen update
Application.ScreenUpdating = True
End If
End Sub
Sub Filtre()
Dim J As Long, Nblg As Long
Dim Ws As Worksheet, WsBase As Worksheet, WbBase As Workbook
Dim Tablo()
Dim I As Integer, Indice As Integer
Dim Chemin As String, Fichier As String
Application.ScreenUpdating = False
Set Ws = ActiveSheet
Chemin = ThisWorkbook.Path & "\"
Fichier = "AP sans macro"
If Dir(Chemin & Fichier) = "" Then
MsgBox "Fichier " & Fichier & " introuvable"
Exit Sub
End If
Set WbBase = Workbooks.Open(Chemin & Fichier)
Set WsBase = WbBase.Sheets(1)
If WsBase.FilterMode = True Then WsBase.ShowAllData
Nblg = WsBase.Range("Period" & Rows.Count).End(xlUp).Row
ReDim Tablo(0)
For J = 3 To Nblg
For I = 0 To UBound(Tablo)
If Tablo(I) = WsBase.Range("Period" & J) Then Exit For
Next I
If I > UBound(Tablo) Then
ReDim Preserve Tablo(Indice)
Tablo(Indice) = WsBase.Range("Period" & J)
Indice = Indice + 1
End If
Sheets("Updates").Select
' Re-activates Display Alerts
Application.DisplayAlerts = True
' Re-activates screen update
Application.ScreenUpdating = True
End If
End Sub
Function FeuilleExiste(WkB As Workbook, Nom As String) As Boolean
On Error Resume Next
FeuilleExiste = WkB.Sheets(Nom).Name <> ""
On Error GoTo 0
End Function