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

 

[sylvanu]

Bonjour telemarrk,
J'ai fait un test ( en invalidant ActualiserFactures car réclame des fichiers externes ), le résultat est correct.
"Actualiser" s'exécute bien et les filtres se mettent bien en place.
Sans fichier test, difficile d'aller plus loin. 🙂

 

[telemarrk]

Bonjour Sylvanu,

Je te joins le fichier Excel, mais je ne peux te joindre les factures PDF.

Merci

 

[sylvanu]

Re,
Votre VBA est protégé. Donc j'ai continué avec mon fichier.
Votre tableau n'a pas de filtre installé, donc ça ne peut pas marcher. ( ça, je n'y avais pas pensé )
Essayez cela qui vérifie si un filtre est présent, sinon il l'installe avant de faire le filtrage :

Sub Actualiser()
' Actualiser Macro
    Set Tablo = Sheets("Factures").ListObjects("Tableau_Struct")
    On Error Resume Next
    If Tablo.AutoFilter.FilterMode Then 'AutoFilter.
       Range("Tableau_Struct[[#Headers],[N°]]").AutoFilter
    End If
    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

 

[telemarrk]

Oups

LE MDP est : DAF en majuscule

 

[sylvanu]

Essayez cette macro pour voir.☺

 

[telemarrk]

Je n'ai pas accès à mon fichier principal qui se trouve sur mon ordinateur de bureau au travail. Cependant, j'ai une copie de sauvegarde chez moi.

J'ai essayé d'appliquer le code que vous m'avez fourni sur cette copie, mais j'ai rencontré un message d'erreur.

Je vous ai joint une capture d'écran de l'erreur.

Merci.

 

[sylvanu]

Re,
Il manquait juste le dim du Tablo.
Un essai en PJ, avec évidemment l'invalidation du module ActualiserFactures, avec :

Sub Actualiser()
' Actualiser Macro
    Dim Tablo
    Set Tablo = Sheets("Factures").ListObjects("Tableau1")
    On Error Resume Next
    If Tablo.AutoFilter.FilterMode Then 'AutoFilter.
       Range("Tableau1[[#Headers],[N°]]").AutoFilter
    End If
    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

Et ça marche correctement :

 

[telemarrk]

Bonjour Sylvanu,

Ça marche nickel sur ma copie à la maison. Je vais essayer la même chose au boulot ce matin et je te fais un petit retour rapide.

Merci

 

[telemarrk]

Sylvanu,

Je reviens vers toi comme promis, cela ne fonctionne pas.

Dès que j'ajoute d'autres factures dans le dossier PDF, il affiche les nouvelles factures à la suite et il ne tient pas compte des filtres.

Exemple, j'ai ajouté des factures destinées aux RH, elles apparaissent dans le tableau Informatique.

Je suis obligé de cliquer sur le bouton actualiser, il ne le fait pas automatiquement au démarrage.

 

[sylvanu]

Re,

Dès que j'ajoute d'autres factures dans le dossier PDF, il affiche les nouvelles factures à la suite et il ne tient pas compte des filtres.

C'est normal, le filtrage installé est statique, pas dynamique. Donc l'état reste comme il était.
( je ne pouvais pas le voir car j'ai inhibé ActualiserFactures donc il n'y avait pas de nouvelles données )
Il faut supprimer les filtrages en cours et le réactualiser.
Essayez avec :

Sub Actualiser()
' Actualiser Macro
    Dim Tablo
    Set Tablo = Sheets("Factures").ListObjects("Tableau1")
    On Error Resume Next
    If Tablo.AutoFilter.FilterMode Then                 'Met un filtre en place si absent.
       Range("Tableau1[[#Headers],[N°]]").AutoFilter
    End If
    With Tablo                                          ' Supprime le filtrage en cours
    If .ShowAutoFilter Then .AutoFilter.ShowAllData
    End With
    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

 

[telemarrk]

Toujours le même problème, comme illustré dans la capture d'écran jointe.

Je me demande si cela pourrait être lié à la fonction "Sub ActualiserFactures()" qui est censée afficher les nouvelles factures.

Merci encore pour votre aide dans la résolution de ce problème.

 

[sylvanu]

Je me demande si cela pourrait être lié à la fonction "Sub ActualiserFactures()" qui est censée afficher les nouvelles factures.

Je pense que vous avez mis le doigt sur le problème. ( évidemment puisque je n'importe aucune donnée )
Vous faites :
1- J'actualise les filtres
2- J'importe les nouveaux fichiers.
Il faudrait faire l'inverse :
1- J'importe les nouveaux fichiers.
2- J'actualise les filtres
Essayez d'inverser les deux lignes :

ActualiserFactures  ' Importation des nouvelles valeurs'
Actualiser          ' Filtrage des données'

 

[telemarrk]

Il semble que cela fonctionne. Je vais continuer mes tests demain. Je vais bientôt quitter mon service, mais je reviendrai vers toi si nécessaire, si cela ne te dérange pas.

Merci