Plantage fichier analyse des codes VBA

Bonjour au forum,

Mon fichier plantait aléatoirement avec ces messages d'erreur : erreur systeMe &h80004005 erreur non spécifié, après avoir été conseillé d'ajouter sur chaque module :

On Error GoTo erreur
Exit Sub
erreur:
Stop: Resume
End Sub

afin d'identifier le problème, celui ci plante de nouveau en me disant qu'il ne peut l'ouvrir mais après réparation j'ai eu ce message : Fonction supprimée: Objet dans la partie /xl/workbook.xml (Classeur)

Je joint donc le fichier complet anonymisé en faisant appel aux spécialistes VBA du site afin de voir dans les codes VBA ce qui pourrait posait problème (mauvaise indentation des codes, problème de conflit entre ceux ci lors de l’écriture de ceux ci...)

Il y a deux modules :

Module 1 :

1 : code de raccourci

2 : 2 fonctions inscrite avec en dessous un code qui permet de déplacer les feuilles sur un autre dossier

Module 2 :
1 : code qui permet de créer un fichier CSV

2 : code qui permet de remettre "A faire" sur les feuilles contenant une validation de données

Sur ThisWorkbook, j'ai mis en place une sauvegarde du fichier à chaque ouverture pour ne pas perdre mes données en cas d'impossibilité de l'ouvrir,

Il y a également un code qui permet de réduire les onglet de la même couleur en un seul, et enfin un code qui me permet d'accéder par des liens hypertexte aux feuilles masquées par le précédent code,

Pour terminer la présentation générale du fichier, il y a également des requêtes mais je ne pense pas que celles ci sont la source de mon problème, mais plus dû aux codes VBA,

Merci d'abord à tous ceux qui participeront, je me doute bien que ce ne sera pas aisé de savoir d’où

vient le problème, d'où mon fichier complet joint,

Cordialement,

Bonjour,

Compte tenu de ce que vous avez écrit, il faudrait être assez inconscient (un euphémisme) pour ouvrir votre fichier.

A minima, mettez vos codes de chacun de vos modules en ligne en utilisant la balise </>, peut-être que quelqu'un aura la réponse.

Bonne chance.

Bonsoir Eric Kergresse,

J'ai joins un fichier car on m'a toujours sur le forums car on m'a toujours conseillé de le faire afin de mieux appréhender les solutions à apporter au problème de chacun,

Mon fichier joint ne risque absolument rien pour celui qui le charge...

Cependant si ça peut aider ceux qui ne souhaite pas l'ouvrir je veux bien mettre les codes des modules et du ThisWorkbook directement ci dessous :

Module 1 :

Public Sub OK()
On Error GoTo erreur
'Raccourci Feuille export
Application.ScreenUpdating = False
Feuil1.Select
Exit Sub
erreur:
Stop: Resume
End Sub
Private Function PréfixeFeuille(ByVal Z As String) As String
   PréfixeFeuille = Left$(Z, PosPExcla(Z))
   End Function
Private Function PosPExcla(ByVal Z As String) As Long
Rem. Le nom de feuille peut contenir "!", et même "'!", ou commencer par "!", pourquoi pas, mais on ne peut
'    se contenter de chercher tout simplement le dernier "!" car la suite de Z peut aussi contenir "#REF!" !
   If Left$(Z, 1) = "'" Then PosPExcla = InStr(Replace(Mid$(Z, 2), "''", "??"), "'!") + 2 Else PosPExcla = InStr(Z, "!")
   End Function
Sub Creer_Fichiers_Classes()
On Error GoTo erreur
Dim F As Worksheet, classe$, P As Range, i As Variant, s, chemin$, c As Range, w As Worksheet, o As Object, nom As Name, sup As Boolean
'---préparation---
Set F = Feuil1 'CodeName
classe = F.DrawingObjects(Application.Caller).Text 'les boutons doivent avoir des noms différents
Set P = F.ListObjects(1).Range 'tableau structuré
i = Application.Match(classe, P.Columns(3), 0) 'EQUIV
If IsError(i) Then MsgBox classe & " non trouvée !", 48: Exit Sub
Set P = P(i, 1).Resize(Application.CountIf(P.Columns(3), classe), P.Columns.Count)
If Application.CountIf(P.Columns(5), "OK") <> P.Rows.Count Then MsgBox "Il faut que tous les onglets de " & classe & " soient validés par OK...": Exit Sub
'---création des dossiers s'ils n'existent pas---
s = Split(P(1, 4), "\")
chemin = s(0) & "\" 'lecteur
For i = 1 To UBound(s)
    chemin = chemin & s(i) & "\"
    If Dir(chemin, vbDirectory) = "" Then MkDir chemin
Next i
'---création des fichiers---
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier a déjà été créé
For Each c In P.Columns(1).Cells
    Set w = ThisWorkbook.Sheets(CStr(c))
    w.Visible = xlSheetVisible 'si la feuille est masquée
    Application.EnableEvents = False 'désactive les évènements
    If c(1, 2) <> c(0, 2) Then 'compare avec le nom de fichier au-dessus
        w.Copy 'crée un nouveau document
    Else
        w.Copy After:=ActiveSheet 'ajoute la feuille copiée
    End If
    Application.EnableEvents = True 'réactive les évènements
    For Each o In ActiveSheet.PivotTables 'TCD
        With o.TableRange2
            s = .Value 'mémorise les valeurs
            .ClearContents 'efface le TCD
            .Value = s 'restitue les valeurs
        End With
    Next o
    For Each o In ActiveSheet.ListObjects 'tableaux structurés
        o.Unlist 'convertit en plage
    Next o
    For Each o In ActiveWorkbook.Connections 'Suppression des connections requêtes
        o.Delete
    Next o
    Range(w.UsedRange.Address) = w.UsedRange.Value 'supprime les formules
    Cells.Hyperlinks.Delete 'supprime les liens hypertextes
    Cells.Validation.Delete 'supprime les liens des listes de données

    If c(1, 2) <> c(2, 2) Then 'compare avec le nom de fichier au-dessous

On Error Resume Next

 For Each nom In ActiveWorkbook.Names
      If PréfixeFeuille(nom.Name) <> PréfixeFeuille(Mid$(nom.RefersTo, 2)) Then nom.Delete
 Next nom

 On Error GoTo 0

        Sheets(1).Select '1ère feuille
        ActiveWorkbook.SaveAs chemin & c(1, 2), 51 'enregistre avec l'extension .xlsx
        ActiveWorkbook.Close False 'ferme le document
    End If
Next c
Exit Sub
erreur:
Stop: Resume
End Sub

Module 2 :

Sub ImportCSV()
On Error GoTo erreur
Dim Tbl As Variant, TblTemp As Variant, FileNumber&, i&, j&, chemin$, T#

FileNumber = FreeFile

'chemin = ThisWorkbook.Path & "\" Fichier sur le même répertoire

chemin = "P:\APEI\5 BILAN\5 CSV IMPORT\" & Range("ANNEE") & "\"

chemin = chemin & "Import_" & Sheets("CSV").Cells(2, 1) & Format(Date, "_YYYY_MM_DD") & ".csv"

Tbl = Range("CSV_INITIAL_2").Value

ReDim TblTemp(LBound(Tbl, 2) To UBound(Tbl, 2))

Open chemin For Output As #FileNumber

For i = LBound(Tbl, 1) To UBound(Tbl, 1)
    For j = LBound(Tbl, 2) To UBound(Tbl, 2)
        TblTemp(j) = Tbl(i, j)
    Next j
    Print #FileNumber, Join(TblTemp, ";")
Next i

Close #FileNumber
Exit Sub
erreur:
Stop: Resume
End Sub

Sub RAZ()
On Error GoTo erreur
    Dim Sh As Worksheet, c As Range, lngValidation As Long

    For Each Sh In Worksheets
        If Sh.Name <> "EN TETE" Then
            With Sh
                For Each c In .UsedRange
                    lngValidation = 0
                    On Error Resume Next
                    lngValidation = c.Validation.Type
                    On Error GoTo 0

                    If lngValidation <> 0 Then
                        c.Value = "A Faire"
                    End If
                Next
            End With
        End If
    Next
MsgBox "Action terminée!"
Exit Sub
erreur:
Stop: Resume
End Sub

ThisWorkbook :

Option Explicit
Private Sub Workbook_Open()

  ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & "SAV -" & ThisWorkbook.Name

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
' la sélection d'un onglet en couleur rend visible
' tous les onglets même couleur.
' Les autres sont masqués sauf le 1er de chaque groupe en couleur.
'
' Les onglets xlSheetVeryHidden ou sans couleur restent inchangés.
'
'
    Dim coul As Long
    Dim sh2 As Worksheet

    coul = Sh.Tab.Color
    For Each sh2 In Worksheets
        If sh2.Index > 1 And Not (sh2.Visible = xlSheetVeryHidden Or sh2.Tab.Color = 0) Then
            If sh2.Tab.Color = coul Then
                sh2.Visible = xlSheetVisible
            Else
                sh2.Visible = sh2.Tab.Color <> Sheets(sh2.Index - 1).Tab.Color
            End If
        End If
    Next sh2
End Sub

Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
    Dim lienSplit() As String
    Dim Feuille As String

    Application.ScreenUpdating = False
    lienSplit = Split(Target.SubAddress, "!")
    If UBound(lienSplit) >= 1 Then
        Feuille = Replace(lienSplit(0), "'", "")
        With ThisWorkbook.Sheets(Feuille)
            If .Visible = False Then
                .Visible = True
                Application.GoTo .Range(lienSplit(1))
            End If
        End With
    Else
        MsgBox ("Lien non valide... " & Target.SubAddress)
    End If
End Sub

Sur deux feuilles j'ai ce code :

Private Sub Worksheet_Activate()

    Application.ScreenUpdating = False
    Me.PivotTables(1).PivotCache.Refresh

End Sub

et celui sur une autre feuille :

Private Sub Worksheet_Activate()

    Application.ScreenUpdating = False
    Range("A2").ListObject.QueryTable.Refresh BackgroundQuery:=False

End Sub

Voila si ça peut aider à résoudre mon problème, merci d'avance,

Cordialement,

Bonjour,

Private Function PosPExcla(ByVal Z As String) As Long
Rem. Le nom de feuille peut contenir "!", et même "'!", ou commencer par "!", pourquoi pas, mais on ne peut
'    se contenter de chercher tout simplement le dernier "!" car la suite de Z peut aussi contenir "#REF!" !

C'est quoi ce Rem ?

Bonsoir Massari59264, JoyeuxNoel,

C'est quoi ce Rem ?

Il est moins utilisé pour inscrire les Remarques. Plus rapide est le '

C'est surement le site qui la bleutée.

Suite,

On Error GoTo erreur

Exit Sub

erreur:

Stop: Resume

End Sub

Une gestion d'erreur global englobant plusieurs traitements me semble inadéquat.

Découper la gestion d'erreurs après des portions de programme afin de voir le déroulement sans accroc du code serait plus souhaitable.

Et permettrait ainsi de valider certains passages.

Bonjour X cellus,

c'est moi qui lui avait conseillé d'ajouter ça vu que ce sont des plantages aléatoires qui le laissent sans partir en débogage dans le code.

Ce n'est pas vraiment un traitement d'erreur.
Le but est que si une erreur est quand même interceptée (ça ce n'est pas gagné...), il puisse retourner sur la ligne l'ayant générée avec un F8 pour l'examiner de plus près.
eric

A nouveau,

Vu la construction du programme. Je lui conseille de tester des portions de code afin de reconnaître s'il répond correctement à son besoin.

Donc s'il lui retourne les bonnes informations et valeurs tout en ayant pour ces portions de programme une gestion d'erreurs afin de les isoler.

Et non pas d'avoir un code global (surtout sans ajouter d'espion ou d'espion express) qui ne lui permet pas de contrôler son déroulement.

Personnellement, là il faut du temps...pour vérifier.

Edit: Je télécharge quand même.

Salut, je ne dirais qu'un mot F8 et tu nous dis sur quelle ligne ça plante.

Soit dis en passant vous pensez qu'avec ce style de codage cela ira plus vite ? C'est surtout très compliqué à lire...

quand on fait une assignation comme ceci Set P = F.ListObjects(1).Range 'tableau structuré il est conseillé de vérifier qu'i n'est pas en Nothing.

Etc etc....

eriiic a écrit :

Bonjour X cellus,

c'est moi qui lui avait conseillé d'ajouter ça vu que ce sont des plantages aléatoires qui le laissent sans partir en débogage dans le code.

Ce n'est pas vraiment un traitement d'erreur.
Le but est que si une erreur est quand même interceptée (ça ce n'est pas gagné...), il puisse retourner sur la ligne l'ayant générée avec un F8 pour l'examiner de plus près.
eric

Bonjour à tous,

Et tout d'bord merci de vous penchez sur mon sujet qui j'avoue ne m'étais jamais arrivé, et donc comme précisé par Eric dans des termes bien plus précis que les miens : "ce sont des plantages sans pouvoir partir en mode débogage", j'avais donc au début ce message d'erreur : erreur systeMe &h80004005 erreur non spécifié

Sur les conseils d'Eric, j'ai mis ce code sur chaque module et sur chaque code :

    On Error GoTo erreur

    Exit Sub

    erreur:

    Stop: Resume

    End Sub

Le fichier ne met plus le message d’erreur système jusqu' à présent, mais ce qu'il s'est passé c'est qu'il me disait qu' Excel ne peut plus ouvrir le programme, je l'ai donc supprimé et ouvert ma sauvegarde, la il me proposé de réparer mon fichier et j'avais ce message : Fonction supprimée: Objet dans la partie /xl/workbook.xml (Classeur)

Pour créer ce fichier, je suis parti d'un fichier vierge et chaque code macro a été construit avec l'aide des forums, car mon niveau VBA est quasi nul,

Xcellus et JeanPaul : le fichier fonctionne et répond a mes besoins, mais j'avoue il y a quelque chose qui plante le fichier sans que je sache pourquoi.

Les macros lorsqu'elles sont exécutées se déroule bien et je n'ai jamais eu un débogage à réaliser lors de l'exécutions de celles ci, et donc comment voulez vous procéder pour "tester des portions de code afin de reconnaître s'il répond correctement à mon besoin", car je pense que oui les codes m'amènent au bon résultat.

"quand on fait une assignation comme ceci Set P = F.ListObjects(1).Range 'tableau structuré il est conseillé de vérifier qu'i n'est pas en Nothing."

Pour répondre a votre conseil Jean Paul, ben j'avoue simplement que je ne suis pas calé en VBA et que c'est un code que l'on m'a proposé et en le testant cela fonctionne bien, que voulez vous dire par "il est conseillé de vérifier qu'il n'est pas en Nothing?,

Est ce que ce serait ce genre de détails qui ferait planter mon fichier?,

Merci à tous de votre participation, ce fichier est très important dans mon travail, j'y ai passé du temps pour le mettre en place, et j'avoue être déçu de ces plantages aléatoires, il serait parfait sans ceux ci ! J'insiste sur le forum pour ne pas abandonné ce fichier et tout le travail qui a été fait,

Merci d'avance,

Cordialement,

Bonjour à toutes et tous,
Que pensez vous de :

classe = F.DrawingObjects(Application.Caller)

DrawingObjects est inconnu !...

Cdlt.

Bonjour Jean eric,

Alors le passage

classe = F.DrawingObjects(Application.Caller).Text 'les boutons doivent avoir des noms différents

J'ai créer des boutons (C1, C2... sur mon fichier original c'est classe 1, classe 2...) qui permettent de lancer cette macro, exemple :

Lorsque je lance C1, il faut que tous les liens sont valides (colonne E), qu'il copie les onglets (colonne A) en les regroupant par fichier (colonne B).

Qu'entendez vous par DrawingObjects est inconnu?

Si lors de l'exécution de la macro les liens ne sont pas tous valides, il me renvoi bien une Msgbox comme précisé sur le code et la référence de la classe est précisé dans le message :

If Application.CountIf(P.Columns(5), "OK") <> P.Rows.Count Then MsgBox "Il faut que tous les onglets de " & classe & " soient validés par OK...": Exit Sub

Merci d'avance pour votre participation,

Cordialement,

Bonjour Jean eric,

Je n'y connais absolument rien en VBA, et je cherche donc des indications sur DrawingObjects

Et je tombe sur un message de Mferrand que j'ai connu ici, et qu'il précisait ceci :

"DrawingObjects est l'ancienne collection remplacée par Shapes à partir de VBA5 (Excel 97) et les ActiveX ont été introduits en même temps avec Microsoft.Forms. Je n'ai pas eu l'occasion de tester ce type de manipulations, mais il est fort possible qu'ils n'aient pas été intégrés à l'ancienne collection et qu'il faille passer par OLEObjects.."

Est ce une ancienne référence qui peut être la source de plantage de mon fichier sur ma version 2016 d'excel ?,

Je m'égare peut être mais je cherche lol,

Cordialement,

Salut à tous

En ce qui concerne le code

 On Error GoTo erreur
    Exit Sub
    erreur:
    Stop: Resume
End Sub

Cela équivaut un peu à ce mettre la main devant les yeux. Ton point d'arrêt sera sur la ligne Stop puisque tu lui demande de s'arrêter, mais tu ne connaitra pas l'erreur.
Utilise plutôt

Sub TestErreur()
'Dim lstR As ListRow
'Dim lstO As ListObject
'Dim lCounter As Long

   On Error GoTo TestErreur_Error

' ICI ton code
'...
'...

TestErreur_Exit:
    Exit Sub

TestErreur_Error:

    MsgBox "Erreur " & Err.Number & " (" & Err.Description & ") dans la procédure TestErreur du Form UserForm1"

    Resume TestErreur_Exit
End Sub

Qui lui affichera le message d'erreur.

Une manière simple et de se mettre dans le premier appelant Sub d'un bouton, initialise d'une UserForm, ou autre et de taper F8 et de suivre le déroulement avec d'autres F8 tu tombera surement sur la ligne qui pose problème.

Pour le Set ... quand tu fait une assignation tu dois vérifier que tout c'est bien passé, si le tableau n'existe plus, que le nom de celui-ci à changé ou autre ton Set te renverra un Object qui sera = à rien Nothing donc ce qui peut poser des problèmes.

Re,
En effet, DrawingObjects (caché) existe encore pour la compatibilité descendante et depuis des lustres.
Regarde pour remplacer :

Sub XXX()
Dim ws As Worksheet
Dim shpName As String, shptext As String

    Set ws = Feuil1
    shpName = Application.Caller
    shptext = ws.Shapes.Range(shpName).TextFrame2.TextRange.Text

    MsgBox shpName
    MsgBox shptext  'Classe

End Sub

Bonjour Jean paul,

Merci pour votre retour, mais puis je le dire ?, lol je n'ai absolument rien comprit

Bon tu suggère déjà de supprimer sur tous mes modules ou il y a un code

 On Error GoTo erreur
    Exit Sub
    erreur:
    Stop: Resume
End Sub

mais pour le reste je ne comprends pas comment le mettre en place :

je créer donc un module, colle le code macro dans ce que tu me propose,

Et après, car quand je lance la macro elle va bien au bout de son traitement,

Donc j'ai loupé une étape dans ton process de vérification,

Je rejoins mon fichier,

Cordialement,

Bonjour Jean Paul,

Alors merci pour votre retour mais que dois je faire pour cette partie ?,

Pour le Set ... quand tu fait une assignation tu dois vérifier que tout c'est bien passé, si le tableau n'existe plus, que le nom de celui-ci à changé ou autre ton Set te renverra un Object qui sera = à rien Nothing donc ce qui peut poser des problèmes.

Pour dire en d’autres termes moins techniques, si le nom de mon tableau change ou n'existe plus, la procédure va demander d'aller le chercher et ça bloquera c'est ça?, si oui comment faire pour l'éviter ?,mais vous pensez que c'est ça qui provoquerai mes problemes de plantage ?,

Dans tous les cas, je suis bien évidemment a votre écoute pour rendre les codes les moins vulnérables possibles à des problèmes éventuels,

Cordialement,

Jean-Eric a écrit :

Re,
En effet, DrawingObjects (caché) existe encore pour la compatibilité descendante et depuis des lustres.
Regarde pour remplacer :

Sub XXX()
Dim ws As Worksheet
Dim shpName As String, shptext As String

    Set ws = Feuil1
    shpName = Application.Caller
    shptext = ws.Shapes.Range(shpName).TextFrame2.TextRange.Text

    MsgBox shpName
    MsgBox shptext  'Classe

End Sub

17massari59264.xlsm (15.16 Ko)

Bonjour Jean Eric,

Désolé d'avoir autant d'incompétences à comprendre ce que vous me dites !!

Donc vous me dites que existe encore et ne pose pas de problème,

Vous me conseiller de regarder le fichier ce que j'ai fait, vous voulez donc que lors de l’exécution de la macro, il aille me chercher le nom de l’objet c'est ça.?,

Si oui, je ne sais pas comment modifier la macro dans son contexte pour arriver à ce que vous me suggérer?, De m^me pensez vous que ce serait la source de mes ennuis de plantage?,

Dans tous les cas je suis preneur pour peaufiner la macro pour moins de bugs éventuels,

Merci d'avance,

Cordialement,

Resume (sans rien derrère) relance la ligne en erreur pour pouvoir contrôler toutes les variables et expressions.
Permet de voir quelle partie est défaillante en utilisant les espions.

Bonsoir Eric,

Merci pour votre retour, pourriez vous cependant m'expliquer comment procéder?,

Cordialement,