XL 2019 Filtrer certains champs au démarrage avec vba

[telemarrk]

Bonjour,

Je rencontre un problème avec mon code Excel VBA. J'essaie de mettre en place un filtrage automatique au démarrage de mon classeur, mais je n'arrive pas à le faire fonctionner correctement. Plus précisément, l'instruction "Actualiser" ne semble pas être prise en compte.

Voici ce que je souhaite réaliser avec le filtrage automatique :

Filtrer la colonne "Suivi" sur "Validé"

Filtrer la colonne "Services" sur "INFORMATIQUE"

Filtrer la colonne "Transmis à la DAF" pour n'afficher que les cellules vides

J'aimerais partager mon code actuel pour obtenir de l'aide. Pourriez-vous examiner mon code et me suggérer des modifications pour résoudre ce problème de filtrage automatique au démarrage, en tenant compte des critères de filtrage mentionnés ci-dessus ?

Merci d'avance pour votre aide.

Option Explicit

Private Sub Workbook_Open()
    ' Désactiver les mises à jour pour optimiser les performances
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    ' Appeler la fonction pour actualiser les factures
    Actualiser
    ActualiserFactures
    
    
    ' Réactiver les mises à jour une fois terminé
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

Sub ActualiserFactures()
    Dim ws As Worksheet
    Dim fso As Object
    Dim dossier As Object
    Dim fichier As Object
    Dim cheminDossier As String
    Dim dictFichiers As Object
    Dim tableauFactures() As Variant
    Dim derniereLigne As Long
    Dim i As Long
    Dim compteur As Long
    
    ' Définir le chemin du dossier PDF
    cheminDossier = "\\192.168.0.32\daf\Ville\En cours\PDF\"
    
    ' Créer une référence à la feuille "factures"
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets("factures")
    On Error GoTo 0
    
    ' Si la feuille n'existe pas, la créer
    If ws Is Nothing Then
        Set ws = ThisWorkbook.Worksheets.Add
        ws.Name = "factures"
    End If
    
    ' Ajouter les titres aux colonnes A, B et C si nécessaire
    If ws.Cells(6, "A").Value = "" Then
        ws.Cells(6, "A").Value = "N°"
        ws.Cells(6, "B").Value = "Factures"
        ws.Cells(6, "C").Value = "Date de dépôt"
        ws.Range("A6:C6").Font.Bold = True
        ws.Range("A6:C6").HorizontalAlignment = xlCenter
    End If
    
    ' Utiliser FileSystemObject pour parcourir les fichiers
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' Vérifier si le dossier existe
    If Not fso.FolderExists(cheminDossier) Then
        MsgBox "Le dossier spécifié n'existe pas.", vbExclamation
        Exit Sub
    End If
    
    ' Créer un dictionnaire pour stocker les fichiers existants
    Set dictFichiers = CreateObject("Scripting.Dictionary")
    
    ' Remplir le dictionnaire avec les fichiers déjà listés
    derniereLigne = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    If derniereLigne >= 7 Then
        For i = 7 To derniereLigne
            dictFichiers(ws.Cells(i, "B").Value) = ws.Cells(i, "C").Value
        Next i
    End If
    
    ' Initialiser un tableau pour stocker les nouvelles données
    Set dossier = fso.GetFolder(cheminDossier)
    compteur = 0
    ReDim tableauFactures(1 To dossier.Files.Count, 1 To 3)
    
    ' Parcourir tous les fichiers PDF dans le dossier
    For Each fichier In dossier.Files
        If LCase(Right(fichier.Name, 4)) = ".pdf" Then
            ' Vérifier si le fichier n'est pas déjà dans le dictionnaire
            If Not dictFichiers.Exists(fichier.Name) Then
                compteur = compteur + 1
                ' Ajouter les nouvelles données au tableau
                tableauFactures(compteur, 1) = derniereLigne - 6 + compteur
                tableauFactures(compteur, 2) = fichier.Name
                tableauFactures(compteur, 3) = fichier.DateCreated
            End If
        End If
    Next fichier
    
    ' Si des nouveaux fichiers ont été trouvés, les ajouter à la feuille
    If compteur > 0 Then
        ws.Cells(derniereLigne + 1, "A").Resize(compteur, 3).Value = tableauFactures
    End If
    
    ' Appliquer le format "jj/mm/aaaa" à la colonne C (Date de dépôt)
    ws.Range("C7:C" & derniereLigne + compteur).NumberFormat = "dd/mm/yyyy hh:mm"
    
    ' Trier le tableau du plus ancien au plus récent
    derniereLigne = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    If derniereLigne >= 7 Then
        With ws.Sort
            .SortFields.Clear
            .SortFields.Add Key:=ws.Range("C7:C" & derniereLigne), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange ws.Range("A7:C" & derniereLigne)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        ' Mettre à jour les index après le tri
        For i = 7 To derniereLigne
            ws.Cells(i, "A").Value = i - 6
        Next i
    End If
    
    ' Ajouter les liens hypertexte aux factures
    Dim cell As Range
    For i = 7 To derniereLigne
        If ws.Cells(i, "B").Value <> "" Then
            ws.Hyperlinks.Add Anchor:=ws.Cells(i, "B"), Address:=cheminDossier & ws.Cells(i, "B").Value, TextToDisplay:=ws.Cells(i, "B").Value
        End If
    Next i
    
    ' Ajuster automatiquement la largeur des colonnes
    ws.Columns("A:k").AutoFit

    ' Libérer les objets
    Set fichier = Nothing
    Set dossier = Nothing
    Set fso = Nothing
    Set dictFichiers = Nothing
End Sub
Sub Actualiser()
'
' Actualiser Macro
'

'
    ActiveSheet.ListObjects("Tableau1").Range.AutoFilter Field:=7, Criteria1:= _
        "<>"
    ActiveSheet.ListObjects("Tableau1").Range.AutoFilter Field:=8, Criteria1:= _
        "Informatique"
    ActiveSheet.ListObjects("Tableau1").Range.AutoFilter Field:=10, Criteria1:= _
        ""
        
End Sub

Private Sub Workbook_Activate()
  Sheets("Factures").Activate
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",False)"
  Application.ActiveWindow.DisplayHeadings = False
  Application.DisplayFormulaBar = False
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Private Sub Workbook_Deactivate()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
Application.DisplayFormulaBar = True
Application.DisplayStatusBar = True
ActiveWindow.DisplayWorkbookTabs = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

 

[telemarrk]

Sylvanu,

J'ai effectué de nouveaux essais et je suis ravi de constater que tout fonctionne parfaitement.
Merci beaucoup pour ton aide.