Chargement du code VBA extrêmement long

Bonjour a tous,

Etant novice j'ai réalisé un fichier excel en m'aidant de chatGPT . Il fonctionne mais je rencontre des problèmes de chargement du code dans Worksheet_Activate de ma feuille Accueil et répertoire accessoire et également lorsque je lance le filtrage de mon tableau de la feuille accueil. j'ai d'autre filtre a ajouter mais je pense que le fichier risque de planter avait vous une solution SVP pour m'éclairer ?

vous pouvez accéder au fichier par le boutons "visiteur" de l userfmor

Merci

Bonsoir,

3 choses possibles à faire et ce n'est pas forcément les seules et si vous les faites "ensemble" alors cela permettrait de gagner du temps d'exécution :

- mettre Application.ScreenUpdating = False en début de code de l'activate, après un test vous passez de 2.5 secondes à 1.5
- ensuite si vous créez une variable boolean Modif (par exemple) et que celle ci soit à True dès qu'il y a une modification de données dans un des tableaux source de votre récap, alors vous reconstruisez le tableau et à l'issu vous passez la variable à False, comme cela si vous activez la feuille alors que cette variable est à false vous n'avez pas à recréer le tableau puisque les données sources n'ont pas évoluées.
- Au lieu de créer le tableau ligne à ligne, le mieux est de passer par un tableau sous VBA qui une fois remplis sera en une seule fois injecté sur le feuille à partir de la cellule B6. A savoir que les accès feuilles entre VBA et le classeur sont chronophages, donc sur un tableau de 200 lignes vous multipliez par 200 ces temps d'accès, alors que l'injection d'un tableau n'utilisera qu'un seul accès.

GTP devrait le savoir !

Une quatrième (à vérifier en fonction des fichiers et des codes car le fait de "couper" ceci prend du temps aussi...) :

Application.ScreenUpdating = False est souvent utilisé en trio avec :
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Et ensuite en fin de procédure on fait l'inverse :
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

@ bientôt

LouReeD

Ce qui m inquiète le plus c est que mes tableaux ne sont remplis qu a 20% en therme de nombre de lignes future

Bonjour,

d'où l'intérêt de passer par "VBA" :
non seulement le tableau Résultat qui sera injecté sur la feuille "récap" mais également les tableaux sources !

Les deux tableaux sources sous VBA seront simple à récupérer vu que vous travaillez avec des tableaux structurés. Le tableau résultat ne sera pas plus compliqué, il faudra jouer peut-être avec des ReDim ou ReDim Preserve, mais rien de bien compliquer en soit.

Tous le travail d'analyse se fera donc en mémoire vive sous VBA ce qui accroit le traitement et vos 20% actuelle passant à 100% ne posera pas de problème !

@ bientôt

LouReeD

Je vais essayer de passer sous tableau vba quel est le nom exact svp? il faut que je m erenseigne et apprenne .

Pour le moment j'ai fais ceci :

Public Modif As Boolean

Sub Worksheet_Change(ByVal Target As Range)
    ' Vérifier si la modification a eu lieu dans les tableaux sources
    If Not Intersect(Target, Me.ListObjects("TAccessoires").DataBodyRange) Is Nothing Or _
       Not Intersect(Target, Me.ListObjects("TVérifications").DataBodyRange) Is Nothing Then
        Modif = True ' Marquer qu'il y a eu une modification
    End If
End Sub

Private Sub Worksheet_Activate()
Application.ScreenUpdating = False ' Désactiver le rafraîchissement de l'écran

    ' Reconstruire le tableau si des modifications ont été apportées
    If Modif Then
        ReconstruireTableau
        Modif = False ' Réinitialiser la variable Modif à False
    End If
      Application.ScreenUpdating = True ' Activer le rafraîchissement de l'écran

End Sub
Sub ReconstruireTableau()

End Sub
    Dim wsAccueil As Worksheet
    Dim wsRepertoireAccessoires As Worksheet
    Dim wsRepertoireVerifications As Worksheet
    Dim loAccueil As ListObject
    Dim loRepertoireAccessoires As ListObject
    Dim loRepertoireVerifications As ListObject
    Dim rowIndex As Long
    Dim i As Long
    Dim identificationNumber As String
    Dim latestDate As Date

    ' Définir les feuilles de travail
    Set wsAccueil = ThisWorkbook.Sheets("Accueil")
    Set wsRepertoireAccessoires = ThisWorkbook.Sheets("Répertoire accessoires")
    Set wsRepertoireVerifications = ThisWorkbook.Sheets("Répertoire vérifications")

    ' Accéder aux listes d'objets
    Set loAccueil = wsAccueil.ListObjects("TExtraction")
    Set loRepertoireAccessoires = wsRepertoireAccessoires.ListObjects("TAccessoires")
    Set loRepertoireVerifications = wsRepertoireVerifications.ListObjects("TVérifications")

    ' Effacer le contenu du tableau existant
    loAccueil.DataBodyRange.ClearContents

    ' Parcourir le tableau TAccessoires
    rowIndex = 1 ' Initialiser l'index de ligne dans le tableau d'extraction
    For i = 1 To loRepertoireAccessoires.ListRows.Count
        ' Ajouter une nouvelle ligne au tableau d'extraction
        loAccueil.ListRows.Add
        ' Copier les informations dans le tableau TExtraction
        With loAccueil.ListRows(rowIndex).Range
            .Cells(1).value = loRepertoireAccessoires.ListRows(i).Range.Cells(1, "A").value ' UNITE/SERVICE
            .Cells(2).value = loRepertoireAccessoires.ListRows(i).Range.Cells(1, "B").value ' DESIGNATION
            .Cells(3).value = loRepertoireAccessoires.ListRows(i).Range.Cells(1, "C").value ' N° D'IDENTIFICATION
            .Cells(4).value = loRepertoireAccessoires.ListRows(i).Range.Cells(1, "D").value ' C.M.U
            .Cells(5).value = loRepertoireAccessoires.ListRows(i).Range.Cells(1, "E").value ' LOCALISATION
            .Cells(6).value = loRepertoireAccessoires.ListRows(i).Range.Cells(1, "F").value ' DATE DE MIS.EN SERV.
            .Cells(7).value = loRepertoireAccessoires.ListRows(i).Range.Cells(1, "G").value ' DATE DE REBUT
            .Cells(8).value = loRepertoireAccessoires.ListRows(i).Range.Cells(1, "H").value ' PERIODICITE
        End With
        rowIndex = rowIndex + 1 ' Incrémenter l'index de ligne dans le tableau d'extraction
    Next i

    ' Mettre à jour la feuille "Accueil" avec les données de TVérifications

    ' Parcourir le tableau TVérifications
    For i = 1 To loRepertoireVerifications.ListRows.Count
        ' Récupérer le numéro d'identification
        identificationNumber = loRepertoireVerifications.ListRows(i).Range.Cells(1, "B").value
        ' Trouver la ligne correspondante dans le tableau TExtraction
        rowIndex = FindRowInListObject(loAccueil, identificationNumber)
        If rowIndex > 0 Then
            ' Mettre à jour la date du contrôle ou détection anomalie dans le tableau TExtraction
            loAccueil.ListRows(rowIndex).Range.Cells(1, loAccueil.ListColumns.Count).value = loRepertoireVerifications.ListRows(i).Range.Cells(1, "A").value
        Else
            ' Ajouter une nouvelle ligne au tableau TExtraction si le numéro d'identification n'existe pas encore
            loAccueil.ListRows.Add
            ' Copier les informations depuis TVérifications
            With loAccueil.ListRows(loAccueil.ListRows.Count).Range
                .Cells(1).value = "" ' UNITE/SERVICE (non trouvé)
                .Cells(2).value = "" ' DESIGNATION (non trouvé)
                .Cells(3).value = identificationNumber ' N° D'IDENTIFICATION
                .Cells(4).value = "" ' C.M.U (non trouvé)
                .Cells(5).value = "" ' LOCALISATION (non trouvé)
                .Cells(6).value = "" ' DATE DE MIS.EN SERV. (non trouvé)
                .Cells(7).value = loRepertoireVerifications.ListRows(i).Range.Cells(1, "A").value ' DATE DE REBUT OU DATE DU CONTRÔLE
                .Cells(8).value = "" ' PERIODICITE (non trouvé)
            End With
        End If
    Next i
End Sub
 Function FindRowInListObject(lo As ListObject, identificationNumber As String) As Long
    ' Recherche du numéro d'identification dans un tableau dynamique
    Dim cell As Range
    Dim foundRow As Long

    foundRow = 0

    For Each cell In lo.ListColumns("N° D'IDENTIFICATION").DataBodyRange
        foundRow = foundRow + 1
        If cell.value = identificationNumber Then
            FindRowInListObject = foundRow
            Exit Function
        End If
    Next cell

    FindRowInListObject = foundRow
End Function

mais tout mes filtres bug

Bonsoir,

ci dessous ma proposition qui est celle où l'on travail en mémoire vive avec des variables VBA représentant les différents tableau (TabE = extraction, TabA = Accessoires, TabV = Vérification) :

'Rempli le tableau a partir des deux autres
Private Sub Worksheet_Activate()
    Dim identificationNumber As String
    Dim latestDate As Date

    Dim TabE(), TabA, TabV, Lig As Long, I, J

    Application.ScreenUpdating = False

    ' on récupère les données de ces tableaux dans une variable VBA qui va alors être considérée comme un tableau à deux dimensions
    TabA = Sheets("Répertoire accessoires").ListObjects("TAccessoires").DataBodyRange
    TabV = Sheets("Répertoire vérifications").ListObjects("TVérifications").DataBodyRange

    ' Réinitialiser le tableau d'extraction
    ' Vérifie si la plage de données de la table structurée n'est pas vide avant de supprimer les lignes
    If Not Sheets("Accueil").ListObjects(1).DataBodyRange Is Nothing Then
        ' Vérifie si la plage de données contient des lignes
        If Sheets("Accueil").ListObjects(1).DataBodyRange.Rows.Count > 0 Then
            ' Supprime toutes les lignes de la plage de données
            Sheets("Accueil").ListObjects(1).DataBodyRange.Rows.Delete
        End If
    End If

    ' Parcourir le tableau TabA
    Lig = 1
    ' on dimensionne le tableau d'extraction avec 8 lignes et 1 colonne
    ' en effet le redim preserve qu'on utilisera plus tard ne fonctionne que sur la dernière dimension qui pour nous est les lignes
    ' il suffira de faire un transpose lors de l'injection sur la feuille
    ReDim TabE(1 To 8, 1 To 1), donc là 8 lignes = 8 colonnes finales, et 1 colonne pour la première ligne de donnée
    For I = 1 To UBound(TabA)
        ' Vérifier si la colonne "DATE DE REBUT" est vide
        If TabA(I, 7) = "" Then
            ' on redimensionne le tableau extraction car une nouvelle donnée va y être inscrite
            ReDim Preserve TabE(1 To 8, 1 To Lig)
            ' Copier les informations dans le tableau TExtraction sauf "DATE DE REBUT"
            For J = 1 To 7
                TabE(J, Lig) = TabA(Lig, IIf(J < 7, J, 8))
            Next J
            ' Récupérer le numéro d'identification
            identificationNumber = TabA(Lig, 3)
            ' Réinitialiser la date la plus récente
            latestDate = DateValue("01/01/1900")
            ' Parcourir le tableau TabV
            For J = 1 To UBound(TabV)
                If TabV(J, 2) = identificationNumber Then
                    ' Récupérer la date du contrôle ou détection anomalie la plus récente
                    If TabV(J, 1) > latestDate Then
                        latestDate = TabV(J, 1)
                    End If
                End If
            Next J
            ' Écrire la date la plus récente dans la dernière colonne du tableau d'extraction
            TabE(8, Lig) = latestDate
            ' on prépare la variable Lig dans le cas qu'au tour suivant il y ait une donnée à inscrire
            Lig = Lig + 1
        End If
    Next I
    ' on injecte le tableau extraction en une fois sur la feuille Accueil avec un transpose afin de "redresser" les lignes en colonnes et inversement
    Sheets("Accueil").Range("B6").Resize(UBound(TabE, 2), UBound(TabE)) = Application.Transpose(TabE)
    ' Mettre la couleur selon la péremption
    ColorOrangeRougeViolet
    RangeRougeOrangeViolet ' Appel de la sub RangeRougeOrangeViolet
    'positionne la vue sur la cellule A1
    Application.GoTo Range("A1"), True ' Fait défiler la feuille pour afficher la cellule A1
End Sub

Si vous avez des questions n'hésitez pas

@ bientôt

LouReeD

Au fait avec des tests chronométrés cela descend à 0.07 secondes !

@ bientôt

LouReeD

Bonjour,

Je n'ai pas fais cas de votre code orangerougeviolet, mais peut-être que des MFC attachées à votre tableau structuré serait suffisant. D'où un gain de temps.

@ bientôt

LouReeD

merci mais ca ne fonctionne pas j'ai bug

Erreur de syntaxe : ReDim TabE(1 To 8, 1 To 1), donc là 8 lignes = 8 colonnes finales, et 1 colonne pour la première ligne de donnée

j'ai essayé : ReDim TabE(1 To 1, 1 To 8) ' Définir le tableau d'extraction avec une seule ligne et 8 colonnes

mais ca bug aussi : Erreur d'exécution '9':

L'indice n'appartient pas a la selection. : ReDim Preserve TabE(1 To 8, 1 To Lig)

Désolé j'ai du mal a saisir :

' Parcourir le tableau TabA
Lig = 1
' on dimensionne le tableau d'extraction avec 8 lignes et 1 colonne
' en effet le redim preserve qu'on utilisera plus tard ne fonctionne que sur la dernière dimension qui pour nous est les lignes
' il suffira de faire un transpose lors de l'injection sur la feuille
ReDim TabE(1 To 1, 1 To 8) ' Définir le tableau d'extraction avec une seule ligne et 8 colonnes

Bonjour,

je ne comprend pas que cela ne marche pas, je vous joint "ma version" :

Bon tests à vous

@ bientôt

LouReeD

Merci effectivement ca fonctionne je ne comprend pas comment je n y suis pas arrivé

Je ne comprend vraiment pas le système transpose je n arrive pas a lire le code , dsl je suis noob

je pense avoir trouvé une parade j'ai ajouté une colonne date a mon tableau accessoire lors de la création

cela evite au code de chercher dans deux tableau pour les jumeler par la suite .

Mais ce que je ne comprend pas c'est pk mon système de couleur ne fonctionne plus dans votre version et ma nouvelle

je n ai pas de message d'erreur mais il ne fonctionne plus ..Incompréhensible

dans mon tableau de la feuille accueil les dates de la dernière colonne doivent êtres rangée de la plus ancienne a la plus récente mais sans succès j ai essayé d autre code idem j ai vérifier les filtre du tableau je trouve rien

Bonjour,

Pas le temps ce matin, vous avez un tableau structuré, il suffit sur la colonne date de faire un tri de la plus vieille vers la plus récente, non ?

@ bientôt

LouReeD

Bonsoir,

il y a un problème sur la source de vos données !
en colonne 8 du tableau de la feuille Accueil, lorsque l'on demande un filtre sur cette colonne voilà ce que l'on a :

Il y a bien les filtres "date" pour 2024, 2023, 2021 et 2019, le reste en dessous ce ne sont pas des dates au sens "d'Excel", ce sont des valeurs alphanumériques qui ressemblent à des dates...
Il faut voir d'où elles viennent et corriger la chose.

Première chose il faut éviter de forcer l'alignement à droite ou à gauche sur des colonnes dates ou numérique. Pourquoi ? Parce que l'alignement des cellules par défaut d'Excel permet d'identifier le contenue d'une cellule au premier coup d'œil :
- alignement à gauche = texte ou valeur alphanumérique
- alignement à droite = numérique
or sous Excel les dates sont des entiers partant de 1 pour le 01/01/1900 et étant à ce jour à 45376 pour le 25/03/2024 soit 45376 jours depuis le 01/01/1900 !
Si on supprime l'alignement "à gauche" de votre colonne voici ce que l'on a :

Les dates du haut alignées à droite = chiffre = "vrai dates" pour Excel, les dates du bas alignées à gauche = alphanumérique = dates pour l'utilisateur mais pas pour Excel. Il est évident dans ces cas là que si vous faites des comparaisons de plus grand ou plus petit cela engendre des erreurs !

Il vous faut dans un premier temps corriger toutes vos colonnes dates. Sinon on ne peut travailler correctement...

@ bientôt

LouReeD

Bonsoir,

en reprenant votre fichier V2 où évidemment les feuilles accessoires et Vérifications sont remplies de dates qui n'en sont pas ET en modifiant un peu le code VBA pour gérer ces défauts, on se retrouve avec un tableau d'extraction dont les deux colonnes 6 et 8 ont bien des dates inscrites reconnues par Excel.

Le code modifié :

Private Sub Worksheet_Activate()
    Dim identificationNumber As String
    Dim latestDate As Date

    Dim TabE(), TabA, TabV, Lig As Long, I, J
    Dim Tempo
    Tempo = Timer
    Application.ScreenUpdating = False

    ' on récupère les données de ces tableaux dans une variable VBA qui va alors être considérée comme un tableau à deux dimmensions
    TabA = Sheets("Répertoire accessoires").ListObjects("TAccessoires").DataBodyRange
    TabV = Sheets("Répertoire vérifications").ListObjects("TVérifications").DataBodyRange

    ' Réinitialiser le tableau d'extraction
    ' Vérifie si la plage de données de la table structurée n'est pas vide avant de supprimer les lignes
    If Not Sheets("Accueil").ListObjects(1).DataBodyRange Is Nothing Then
        ' Vérifie si la plage de données contient des lignes
        If Sheets("Accueil").ListObjects(1).DataBodyRange.Rows.Count > 0 Then
            ' Supprime toutes les lignes de la plage de données
            Sheets("Accueil").ListObjects(1).DataBodyRange.Rows.Delete
        End If
    End If

    ' Parcourir le tableau TAccessoires
    Lig = 1
    ' on dimensionne le tableau d'extraction avec 8 ligne et 1 colonne
    ' en effet le redim preserve qu'on utilisera plus tard ne fonctionne que sur la dernière dimension qui pour nous est les lignes
    ' il suffira de faire un transpose lors de l'injection sur la feuille
    ReDim TabE(1 To 8, 1 To 1)
    For I = 1 To UBound(TabA) ' loAccessoires.ListRows.Count
        ' Vérifier si la colonne "DATE DE REBUT" est vide
        If TabA(I, 7) = "" Then
            If I = 88 Then
                I = I
                End If
            ' on redimensionne le tableau extraction car une nouvelle donnée va y être inscrite
            ReDim Preserve TabE(1 To 8, 1 To Lig)
            ' Copier les informations dans le tableau TExtraction sauf "DATE DE REBUT"
            For J = 1 To 7
                If J = 6 Then ' date
                    TabE(J, Lig) = dateValue(TabA(Lig, 6)) * 1
                ElseIf J = 7 Then
                    TabE(J, Lig) = TabA(Lig, 8)
                Else
                    TabE(J, Lig) = TabA(Lig, J)
                End If
            Next J
            ' Récupérer le numéro d'identification
            identificationNumber = TabA(Lig, 3) 'loAccessoires.ListRows(i).Range.Cells(1, "C").value
            ' Réinitialiser la date la plus récente
            latestDate = dateValue("01/01/1900")
            ' Parcourir le tableau TVérifications
            For J = 1 To UBound(TabV) 'loVerifications.ListRows.Count
                If TabV(J, 2) = identificationNumber Then
                    ' Récupérer la date du contrôle ou détection anomalie la plus récente
                    If TabV(J, 1) > latestDate Then
                        latestDate = TabV(J, 1)
                    End If
                End If
            Next J
            ' Écrire la date la plus récente dans la dernière colonne du tableau d'extraction
            TabE(8, Lig) = dateValue(latestDate) * 1
            ' on prépare la variable Lig dans le cas qu'au tour suivant il y ait une donnée à inscrire
            Lig = Lig + 1
        End If
    Next I
    ' on injecte le tableau extraction en une fois sur la feuille Accueil avec un transpose afin de "redresser" les lignes en colonnes et inversement
    Sheets("Accueil").Range("B6").Resize(UBound(TabE, 2), UBound(TabE)) = Application.Transpose(TabE)
    ' Mettre la couleur selon la péremption
    ColorOrangeRougeViolet
    RangeRougeOrangeViolet ' Appel de la sub RangeRougeOrangeViolet
    'positionne la vue sur la cellule A1
    Application.GoTo Range("A1"), True ' Fait défiler la feuille pour afficher la cellule A1
    MsgBox Timer - Tempo
End Sub

Il y a encore les codes de mise en couleur, mais je persiste en disant que des MFC conditionnelles sur le tableau final seraient bien plus simple, il suffit de connaître le but recherché. Ces MFC "résistent" à la suppression des lignes du tableau, donc une fois en place, elle restent.

Il est évident que la variable Tempo est à supprimer ainsi que les deux lignes s'y référent : Tempo = Timer et MsgBox Timer - Tempo

@ bientôt

LouReeD

j'ai fait un tri via filtre tableau structuré et ca ne fonctionné pas effectivement je me suis également aperçu que les dates étaient erronée j'ai du mettre a jour toute les valeurs en récupèrent les données sur un vieux tableau et c est ok

Pour éviter de croiser deux tableau j ai apporté des modif pour ne récupérer les élément que d un seul tableau

j ai essayé de suivre vos conseil j'ai ajouté : Application.ScreenUpdating = True

et mis mon code dans un module boelan

pour passer par un tableau sous VBA j ai beau chercher je ne comprend pas j'ai l impression que c est juste un langage de code diffèrent qui se réfère au nombre de colonne au lieu de position de grille ?

Je vous joint mon nouveau tableau avec toute ces modif

Bonjour,

de mon côté il est rapide, si tout est clean de votre côté alors il n'y a plus rien à faire, en plus votre code est ultra simplifié.
bravo à vous

@ bientôt

LouReeD

merci pour votre aide

Si tout va pour le mieux de votre côté, alors bonne continuation dans votre projet.
merci de vos remerciements !

@ bientôt

LouReeD