XL 2021 VBA - Erreur 1004 aléatoire - Image/Logo

DeeJas

XLDnaute Nouveau
Bonjour,

J'ai un souci depuis un long moment que je n'arrive pas à résoudre malgré la quantité de sujet que j'ai consulté sur le net sur cette erreur.
J'espère que vous pourrez m'aider, je partage le code (j'ai supprimé ce qui n'était pas nécessaire pour que le code soit lisible).

Le code ajoute/supprime des logos en fonction des symboles insérés par les utilisateurs si ceux-ci existent.
Ces logos sont récupérés via une requête et stockés sous forme d'URL dans des feuilles.

J'ai essayé avec les 2 fonctions "Logo" et "SupprimerImage" que vous retrouverez ci-dessous. Le résultat est le même, cependant j'ai aléatoirement l'erreur 1004 : Erreur définie par l'application ou par l'objet dans la fonction "SupprimerImage" (j'ai tagué la ligne dans le code) et ce peu importe si on est dans le "cas 1" ou le "cas 2" (tagué dans le code).

PS: J'ai remarqué que lorsque l'erreur survient, pour la bypass, il me suffit d'effacer le symbole, allez au débogage, réinitialiser, sauvegarder le doc, le réouvrir et réinsérer le symbole. Après je n'ai plus d'erreur pendant un moment, je peut donc changer le symbole, le supprimer, les logos fonctionnent correctement en conséquences.

Merci d'avance pour votre aide.

VB:
Private Sub Worksheet_Change(ByVal Target As Range)

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With

If Target.Count > 1 Then
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
    Exit Sub
End If

Select Case Target.Column
    Case Is = 3 'Colonne Symbole
        If Target <> "" Then 'Cas 1 : Si le symbole inséré est non vide
            Target = UCase(Target)
          
            Call BDD_Images(Target)
        Else: 'Cas 2 : Si le symbole est vide
            Call SupprimerImage(Target.Offset(0, -2))
        End If
End Select
  
  
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
End Sub

'Function SupprimerImage(imgPos As Range)
'    Dim Image As Object
'    For Each Image In Worksheets("Transactions").Shapes
'        If Image.TopLeftCell.Address = imgPos.Address Then
'            Image.Delete
'            Exit Function
'        End If
'    Next Image
'End Function

Function SupprimerImage(imgPos As Range)
    Dim Image As Object
    For Each Image In Worksheets("Transactions").Shapes
        If Not Intersect(Image.TopLeftCell, imgPos) Is Nothing Then ' Erreur 1004 : Erreur définie par l'application ou par l'objet
            Image.Delete
        End If
    Next Image
End Function

'Function Logo(img As Range)
'    With ActiveSheet.Pictures.Insert(img.Value)
'        .ShapeRange.LockAspectRatio = msoFalse
'        .Width = img.Width - 10
'        .Height = img.Height - 3
'        .Top = Rows(img.Row).Top + 2
'        .Left = Columns(img.Column).Left + 5
'        .Placement = xlMoveAndSize
'        .Locked = True
'    End With
'    img.Value = "" 'On efface l'url pour ne garder que l'image
'End Function

Function Logo(img As Range)
    Worksheets("Transactions").Shapes.AddPicture img.Value, msoTrue, msoTrue, Columns(img.Column).Left + 5, Rows(img.Row).Top + 2, img.Width - 10, img.Height - 3

    img.Value = "" 'On efface l'url pour ne garder que l'image
End Function

Function BDD_Images(Compare As Range)
    Dim PosLigne As Range
  
    Set PosLigne = Compare.Offset(0, -2)
    Call SupprimerImage(PosLigne)
  
    If Compare = "EUR" Then
        PosLigne = "https://seeklogo.com/images/E/Euro-logo-6333317E36-seeklogo.com.png"
        Call Logo(PosLigne)
        Exit Function
    ElseIf Compare = "USD" Then
        PosLigne = "https://em-content.zobj.net/source/microsoft-teams/337/heavy-dollar-sign_1f4b2.png"
        Call Logo(PosLigne)
        Exit Function
    End If
  
    Dim Val(40) As Range, i As Integer, Resultat As String
  
    For i = 1 To 40
        Set Val(i) = Worksheets("API_CG_" & i).Range("C2:C251").Find(Compare, lookat:=xlWhole) 'Recherche dans les tableaux API_CG_1 à 40
        If Not Val(i) Is Nothing Then 'Si on retrouve le symbole contenu dans la variable "Compare"
            PosLigne = Val(i).Offset(0, 2) 'On enregistre l'url de l'image dans la variable "PosLigne"
            Resultat = Compare 'On bloque le symbole retrouvé dans la variable "Resultat"
            Call Logo(PosLigne)
            Exit Function 'On arrête ici pour ne prendre que le premier symbole et ainsi éviter les doublons
        End If
    Next i
  
    If Resultat <> Compare Then
        Set Val(0) = Worksheets("API_CMC").Range("C2:C10001").Find(Compare, lookat:=xlWhole) 'Si on ne retrouve pas le symbole dans l'API CG, on recherche dans l'API CMC.
        If Not Val(0) Is Nothing Then 'Si on retrouve le symbole contenu dans la variable "Compare"
            Resultat = Compare 'On bloque le symbole retrouvé dans la variable "Resultat"
        Else: Compare = "-" 'Si le symbole est introuvable, on retourne "-" dans la case Symbole pour la mise en forme conditionnelle
        End If
    PosLigne = "https://cdn.icon-icons.com/icons2/317/PNG/512/sign-error-icon_34362.png"
    Call Logo(PosLigne)
    End If
End Function
 
Dernière édition:

crocrocro

XLDnaute Occasionnel
Bonjour Deejas,
avec un fichier ce serait plus facile de répondre (pensez à anonymiser les données présentes.
Une supposition :
La fonction SupprimerImage est appelée dans le Worksheet_Change.
Est-ce bien sur la feuille "Transactions" ?
Si ce n'est pas le cas, le test
VB:
        If Not Intersect(Image.TopLeftCell, imgPos) Is Nothing

provoquera l'erreur 1004
 

crocrocro

XLDnaute Occasionnel
Je détaille ma réponse précédente :
imgPos provient de la lign de code suivant dans l'événement Worksheet_Change
VB:
Call SupprimerImage(Target.Offset(0, -2))
imgPos est donc un "Range" de la feuille dont on compare l'intersection avec le "Range" Image.TopLeftCell de la feuille "Transactions".
Intersection de 2 Ranges situées dans ds feuilles différentes, heu! heu! heu !
 

DeeJas

XLDnaute Nouveau
Bonjour,
Ok, je vous partage ça.

J'ai supprimé presque la totalité du code et des feuilles pour ne laisser que l'essentiel, ça devrait faciliter la tâche. J'ai aussi dû modifier et énormément alléger les requêtes pour pouvoir envoyer le fichier (1mo max).

J'ai également une erreur qui survient de temps à autre dans la feuille "Statuts", j'ai laissé un commentaire sur la ligne concernée. De mémoire c'est également une erreur 1004 mais sans certitude puisque c'est assez rare.

Concernant la feuille "Transactions", pour déclencher l'erreur il vous suffira d'insérer un symbole colonne C. J'espère que vous aurez l'erreur rapidement car comme je l'ai précisé, elle survient aléatoirement.
 

Pièces jointes

  • Tableau.xlsm
    954.7 KB · Affichages: 2

crocrocro

XLDnaute Occasionnel
Bonjour Deejas,
Dans un 1er temps, J'ai désactivé la planification de la requête sur le WorkbookOpen .
Sur la fenêtre suivante, prudent sur mes connexions internet, j'ai annulé
1706044143623.png


En conséquence , j'ai l'erreur suivante :
1706044199956.png

Qui ne m'empêche pas d'effectuer des saisies, comme vous me l'avez indiqué sur la feuille Transactions.
1 - En cas de saisie d'un symbole inexistant (j'ai saisi "fff"), une vilaine erreur dans la fonction sur la ligne
Code:
Set Val(i) = Worksheets("API_CG_" & i).Range("C2:C251").Find(Compare, lookat:=xlWhole) 'Recherche dans les tableaux API_CG_1 à 40

1706044541651.png


Dans la fonction BDD_Images, pour éviter l'erreur, il faut Tester la valeur retournée avant de l'affecter à Val(i)

2- pour une saisie correcte par exemple EUR sur une ligne vide, pas d'erreur sur la fonction SupprimerImage (rien à supprimer)
3- pour un emplacement d'un symbole par un autre, pas d'erreur au niveau de la fonction SupprimerImage
Code:
Function SupprimerImage(imgPos As Range)
    Dim Image As Object
    For Each Image In Worksheets("Transactions").Shapes
        If Not Intersect(Image.TopLeftCell, imgPos) Is Nothing Then
        ' Erreur 1004 : Erreur définie par l'application ou par l'objet
            Image.Delete
        End If
    Next Image
End Function
La suppression de l'image se fait correctement pour la cellule ciblée.
Une remarque : un Exit For après le Delete, normalement, il n'y a plus d'image à supprimer

Je n'ai pas testé la fenêtre Statuts, avec la connexion annulée, cela parait inutile.
Désolé se ne pas avoir pu identifier votre erreur
 

DeeJas

XLDnaute Nouveau
Bonsoir,

Merci pour votre réponse.

En cas de saisie d'un symbole inexistant (j'ai saisi "fff"), une vilaine erreur dans la fonction sur la ligne
Oui, normal c'est de ma faute. Dans la version que j'ai partagé, j'ai oublié de modifier :
VB:
Set Val(i) = Worksheets("API_CG_" & i).Range("C2:C51").Find(Compare, lookat:=xlWhole)

J'ai allégé les requêtes et j'ai oublié de modifier le code ci dessus et ci dessous :
VB:
Set Val(0) = Worksheets("API_CMC").Range("C2:C81").Find(Compare, lookat:=xlWhole)

Du coup, ça évite l'erreur 9 mais ce n'est pas ça le réel problème.
J'ai rajouté le Exit For car on est jamais trop avare d'optimisation.

Vous n'avez pas d'idée pour la fonction SupprimerImage ?
Le problème étant aléatoire, peut être qu'en ouvrant/fermant le classeur à plusieurs reprises, finirez-vous par avoir l'erreur.

C'est rare que je demande de l'aide car quand je ne sais pas je cherche ou je me forme. Là je sèche totalement.
 
Dernière édition:

crocrocro

XLDnaute Occasionnel
Difficile de trouver une solution quand on arrive pas à reproduire l'erreur 🥲
Pour pister les erreurs, je vous propose de modfier la fonction SupprimerImage comme suit
VB:
Function SupprimerImage(imgPos As Range)
    Dim Image As Object
    Dim NbDelete As Integer
    NbDelete = 0
    For Each Image In Worksheets("Transactions").Shapes
        If Not Intersect(Image.TopLeftCell, imgPos) Is Nothing Then
        ' Erreur 1004 : Erreur définie par l'application ou par l'objet
            On Error GoTo ErreurDelete
            Image.Delete
            NbDelete = NbDelete + 1
        End If
    Next Image
    If NbDelete > 1 Then MsgBox "pourquoi " & NbDelete & " Delete ?"
    Exit Function
ErreurDelete:
    MsgBox "Erreur " & Err.Number & " : " & Err.Description & vbCrLf & _
    "imgPos : " & imgPos.Address & " - Feuille courante : " & activesheet.name, vbCritical, SupprimerImage
    On Error GoTo 0
End Function

Quelques explications (peut-être inutiles) :
- Le On Error GoTo permet d'intercepter les erreurs. Ici, si une erreur est rencontrée sur la ligne Delete, on affichera l'erreur avec l'adresse de imgpos et le nom de la feuille courante (qui devrait être "Transactions".
- Normalement on ne devrait avoir qu'un seul Delete. Grâce à la variable NbDelete, s'il y en a plusieurs on affichera également un message.

Autres remarques :
Le Exit For après le Delete (que je n'ai pas mis ici), optimise très peu le code, mais c'est plus "propre". C'était potentiellement, mais je n'y crois pas, la source de l'erreur.
Autre possibilité, mais je n'y crois pas non plus, la macro planifiée toutes les minutes pourrait perturber l'exécution en cours.

Bonne chasse !
 
Dernière édition:

DeeJas

XLDnaute Nouveau
Merci pour votre réponse et vos explications qui sont complètes.

Autre possibilité, mais je n'y crois pas non plus, la macro planifiée toutes les minutes pourrait perturber l'exécution en cours.
L'erreur est antérieur de mémoire, donc je ne pense pas non plus.

J'ai intégré votre code dans mon classeur. Je vais tester avec mon classeur et le classeur partagé en même temps pendant quelques jours.
De cette manière je pourrai voir si un des deux classeurs ou les deux finissent par avoir l'erreur.

Quoi qu'il arrive, je reviendrai prochainement ici indiquer si votre code était la solution ou le debug.
 

crocrocro

XLDnaute Occasionnel
Pour finir :
si malgré l'erreur, tout fonctionne normalement, c'est à dire ici, le symbole est supprimé,, vous pouvez mettre un
VB:
             On Error Resume Next
            Image.Delete
            On Error Goto 0
qui permet d'ignorer l'erreur (sur l'instruction Delete uniquement)
 

Discussions similaires

Statistiques des forums

Discussions
313 201
Messages
2 096 177
Membres
106 516
dernier inscrit
Pagny