VBA boite de dialogue macro filtre

Re : VBA boite de dialogue macro filtre

Bonjour,

Même discussion qu'ici:https://www.excel-downloads.com/threads/vba-probleme-serieux-pour-moi.213390/ pour laquelle tu n'as pas obtenu de réponse. visiblement tu n'as changé Que le titre de ta discussion.

Peut-être n'as - tu pas saisi l'esprit du forum, qui est le partage et non la réalisation de macro suivant un cahier des charges développé par le demandeur. Pour cela il y a les professionnels, auxquels nous n'avons pas à faire concurrence.

Sans doute, qu'en commençant tes macros et en disant quelles difficultés tu rencontres dans leur réalisation, en posant une question sur un point précis, tu aurais plus de réponse.

A+

Re : VBA boite de dialogue macro filtre

Merci pour ton message.
j'ai ai travaillé sur ma macro mais elle me permet juste de faire des filtres en splittant mes périodes. or c'est pas ce que je veux. je veux le faire avec une boite de dialogue mais je suis pas doué pour ça. des petites macro encore je peux mais ça j'aurai vraiment besoin d'aide

merci

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