Erreur macro sur fonction "If Not Intersect..." Résolu/Fermé

Question

Bonjour à tous, 

Je débute en macro, et à force de patience de d'heures de lecture sur les forum adéquats, je parviens petit à petit à faire ce que je veux. Cependant, voila que je me heurte à un problème que je n'arrive pas à résoudre malgré mon acharnement depuis quelques jours.

J'ai une feuille de calcul donc avec un macro qui contient ce code (pour nettoyer une zone de la feuille de toutes les formes qui y sont intégrées). La seconde partie servant à supprimer le contenu de la cellule permettant via une autre macro d'y intégrer ces fameuses formes

Sub Effacer_forme_zone_dessin()    ActiveSheet.Unprotect "moncode"        For Each s In ActiveSheet.Shapes            If Not Intersect(s.TopLeftCell, Range("$B$31:$Z$47")) Is Nothing Then                s.Delete            End If        Next s    ActiveSheet.Protect "moncode"End SubSub Effacer_code_chassis()    ActiveSheet.Range("Y48").Select    Selection.ClearContentsEnd Sub

Macro activée par un bouton auquel est appliqué ce code :

Sub Nettoyer_zone_dessin()    Call Effacer_forme_zone_dessin    Call Effacer_code_chassisEnd Sub

Le problème est le suivant. Lorsque j'applique cette macro, l'effacement se fait sans soucis. En revanche, si je  modifie une zone en particulier dans la feuille (définie plus bas dans ce message), la macro présente une "Erreur d'exécution '1004' ...".

La zone modifiée qui provoque ce blocage de la macro est la suivante... Dans la feuille, ce code qui affiche ou masque des shapes (shapes dans une zone autre que celle qui est nettoyé par la macro qui pose problème définie plus haut) :

Private Sub Worksheet_Change(ByVal Target As Range)        If [H19] = "En tunnel" Then 'Si cellule H19 = "En tunnel"        ActiveSheet.Shapes("Rectangle 1").Visible = True 'Affiche la forme        ActiveSheet.Shapes("Rectangle 2").Visible = False 'Masque la forme        ActiveSheet.Shapes("Rectangle 3").Visible = False 'Masque la forme        ActiveSheet.Shapes("Rectangle 4").Visible = False 'Masque la forme    ElseIf [H19] = "En applique intérieure" Then        ActiveSheet.Shapes("Rectangle 1").Visible = False 'Masque la forme        ActiveSheet.Shapes("Rectangle 2").Visible = True 'Affiche la forme        ActiveSheet.Shapes("Rectangle 3").Visible = False 'Masque la forme        ActiveSheet.Shapes("Rectangle 4").Visible = False 'Masque la forme    ElseIf [H19] = "En applique extérieure" Then        ActiveSheet.Shapes("Rectangle 1").Visible = False 'Masque la forme        ActiveSheet.Shapes("Rectangle 2").Visible = False 'Masque la forme        ActiveSheet.Shapes("Rectangle 3").Visible = True 'Affiche la forme        ActiveSheet.Shapes("Rectangle 4").Visible = False 'Masque la forme    ElseIf [H19] = "Autre" Then        ActiveSheet.Shapes("Rectangle 1").Visible = False 'Masque la forme        ActiveSheet.Shapes("Rectangle 2").Visible = False 'Masque la forme        ActiveSheet.Shapes("Rectangle 3").Visible = False 'Masque la forme        ActiveSheet.Shapes("Rectangle 4").Visible = True 'Affiche la forme    ElseIf [H19] = "" Then        ActiveSheet.Shapes("Rectangle 1").Visible = False 'Masque la forme        ActiveSheet.Shapes("Rectangle 2").Visible = False 'Masque la forme        ActiveSheet.Shapes("Rectangle 3").Visible = False 'Masque la forme        ActiveSheet.Shapes("Rectangle 4").Visible = True 'Affiche la forme    End IfIf Not Application.Intersect(Target, Range("Y48")) Is Nothing Then    Call Inserer_schema1à100_F1    Call Inserer_schema101à200_F1    Call Inserer_schema201à300_F1End IfEnd Sub

Si la feuille est ouverte avec la Shapes "Rectangle 1" en "True" et les autres en "False", alors le nettoyage se fera sans soucis, et si je change, message d'erreur. Et si je reviens sur "Rectangle 1", ça ne se remettra pas à marcher pour autant.
Un vrai casse-tête :/

Pas évident de fournir des explications claires sans vous joindre le fichier. Y a-t-il une plateforme sur laquelle je pourrais déposer ce fichier pour que vous y voyiez plus clair, et réussissiez j'espère à m'éclairer sur ce problème

Configuration: Windows 7 / Chrome 43.0.2357.124 / Microsoft Excel 2010

ccm81 · Answer

Bonjour

Déposes ton fichier sur cjoint.com et joins le lien obtenu à ton prochain message

Cdlmnt

eriiic · Answer

Bonjour,

J'ai réussi à le faire planter une seule fois, il ne plante plus bien que je n'ai pas sauvegardé après (?)
J'ai eu le temps de voir que c'était un objet nommé "Drop Down 171" qui l'embêtait.
Peut-être pas de propriété TopLeftCell, ce qui serait étonnant, ou un objet fantôme (re ?) avec un nettoyage incomplet.
Tu pourrais te servir de s.type pour ne traiter que des objet du type attendu dans cette plage (en espérant qu'il soit ailleurs), ou du début de s.name selon ce qui est le plus pratique pour toi.
Ou bien traiter l'erreur puisque bizarrement cet objet a l'air de disparaitre tout seul

Si ça peut t'aider à avancer...

eric

Éternité... · Answer

J'ai réussi à résoudre le problème grâce à la suggestion de eriiic vis-à-vis du s.Type.

Code modifié :
Sub Effacer_forme_zone_dessin()    ActiveSheet.Unprotect "moncode"        For Each s In ActiveSheet.Shapes            If s.Type = msoPicture Or s.Type = msoLinkedPicture Then            If Not Intersect(s.TopLeftCell, Range("$B$31:$Z$47")) Is Nothing Then                s.Delete            End If            End If        Next s    ActiveSheet.Protect "moncode"End Sub

Par contre ça ne m'efface que les image insérées par un "copier une zone de cellule" et "coller en tant qu'image".
Or dans cette zone, j'ai également la possibilité d'insérer des images externe via le code qui suit :

Public Sub insere_image()     Dim ficimg As Variant     ActiveSheet.Unprotect "moncode"     On Error Resume Next    ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image")     ActiveSheet.Pictures.Insert(ficimg).Select ' insertion     With Selection        .Locked = False        .PrintObject = True        .Placement = xlMoveAndSize    End With    ActiveSheet.Protect "moncode" End Sub

Avec la modification du code précédent, les images insérées via le bouton "Public Sub insere_image()" ne se supprimer pas lors du nettoyage.
Je vais continuer à creuser, si d'ici mon prochain post quelqu'un a une suggestion, je suis bien entendu preneur =)

eriiic · Answer

Bonjour,

Il n'y a pas vraiment de .Refresh ou .Repaint pour les feuilles, c'est sensé être toujours bon ;-)
Tente avec :
    ActiveWindow.SmallScroll Down:=1
    ActiveWindow.SmallScroll Down:=-1
ou des trucs comme ça.

Rien à voir mais pour ton Module3 tu peux peut-être remplacer tes 20000 lignes de codes par qq chose comme :
Sub Inserer_schema_F1()
    Dim v As Long, pl As Range, c As Range, lig As Long, fini As Boolean, a
    ' v = CLng([Y48])
    v = 217    ' pour tests
    If v <= Application.Max(Cells) Then
        ActiveSheet.Unprotect "moncode"
        Sheets("Schémas").Activate
        Set pl = Cells.Find(v, LookIn:=xlFormulas, Lookat:=xlWhole)
        Set pl = pl.MergeArea
        Set pl = pl.Offset(1, -1).Resize(, pl.Columns.Count + 2)
        Set c = pl.Range("A1")
        Do
            Set c = c.Offset(1)
            If c.Borders(xlEdgeRight).LineStyle = xlNone Then
                Set pl = pl.Resize(pl.Rows.Count + 1)
                Exit Do
            Else
                Set pl = pl.Resize(pl.Rows.Count + 1)
            End If
        Loop
        pl.Select ' pour tests
        Stop ' pour tests
        pl.Copy
        Sheets("Fiche minute 1").Activate
        Range("B32").Select
        ActiveSheet.Pictures.Paste
        ActiveSheet.Protect "moncode"
    End If
End Sub
Je cherche ton nombre sur la feuille (il faut qu'il soit unique). Comme il est dans une cellule fusionnée (presque) à la bonne largeur j'agrandi la sélection décalée et retaillée d'une ligne tant qu'il y a une bordure à gauche.
Pas tout testé tes 225 schémas bien sûr...
Un problème détecté quand même pour tes fenêtres. Ca passe si tu prolonges le trait à gauche avec des pointillés par exemple jusqu'à la vue de dessus qui doit être sélectionnée avec.
 
Si tes tests confirment que c'est ok tu pourras ajouter des shémas, les déplacer etc sans retoucher au code.
A voir...

eric

Erreur macro sur fonction "If Not Intersect..."

4 réponses

Discussions similaires