XL 2019 PasteSpecial

GUERET

XLDnaute Occasionnel
Bonjour, j'ai un petit souci avec mon fichier car de temps en temps j'obtiens ce message : Erreur d'execution La méthodes PasteSpecial de la range a échouée

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("H3")) Is Nothing Then
ListerCourses
End If
End Sub


Private Sub Worksheet_Activate()
Dim c As Range, sh As Shape


Application.ScreenUpdating = False
For Each sh In Feuil2.Shapes
sh.Delete
Next
For Each sh In Feuil27.Shapes
If sh.TopLeftCell.Column = 4 Then
If Not IsError(Application.Match(Feuil27.Range("B" & sh.TopLeftCell.Row), Feuil2.Range("B5:B35"), 0)) Then
sh.Copy
Feuil2.Range("A3").Offset(Application.Match(Feuil27.Range("B" & sh.TopLeftCell.Row), Feuil2.Range("B5:B35"), 0), 0).PasteSpecial
End If
End If
Next
For Each sh In Feuil2.Shapes
sh.Height = sh.TopLeftCell.Height
Next
Application.ScreenUpdating = True
End Sub

Ca fout la grouille dans mes photos en feuille "pilotes", parfois dans mes feuilles de courses. Il faut alors que j'aille sur une autre feuille pour que tout rentre dans l'ordre. Qui plus est, dans ma feuille 'Pilotes", la photo du dernier pilote SAVADORI Lorenzo n'apparait plus. Où se situe donc le problème ???
D'avance, merci

 

AtTheOne

XLDnaute Impliqué
Supporter XLD
Bonsoir à toutes & à tous, bonsoir @GUERET
la photo du dernier pilote SAVADORI Lorenzo n'apparait plus. Où se situe donc le problème ???
Il y a 2 occurrences de SAVADORI Lorenzo sur tes feuilles "Photos" et "Pilotes" respectivement en D28 & D34 sur Photos et B27 & B35 sur Pilotes. Les deux photos sont en fait superposées en A27.
Pour le bug je n'arrive pas à le reproduire. Je cherche un peu plus et je reviens vers toi
Amicalement
Alain
 

AtTheOne

XLDnaute Impliqué
Supporter XLD
Re,
la photo en D28 est en fait celle de michele pirro
1651343032310.png

qui n'apparaît pas dans tes deux listes (Photos & Pilotes)
à plus
Alain
 

GUERET

XLDnaute Occasionnel
Bonsoir à toutes & à tous, bonsoir @GUERET

Il y a 2 occurrences de SAVADORI Lorenzo sur tes feuilles "Photos" et "Pilotes" respectivement en D28 & D34 sur Photos et B27 & B35 sur Pilotes. Les deux photos sont en fait superposées en A27.
Pour le bug je n'arrive pas à le reproduire. Je cherche un peu plus et je reviens vers toi
Amicalement
Alain
Merci pour ton attention et bon WE.
 

GUERET

XLDnaute Occasionnel
Bonsoir à toutes & à tous, bonsoir @GUERET

Il y a 2 occurrences de SAVADORI Lorenzo sur tes feuilles "Photos" et "Pilotes" respectivement en D28 & D34 sur Photos et B27 & B35 sur Pilotes. Les deux photos sont en fait superposées en A27.
Pour le bug je n'arrive pas à le reproduire. Je cherche un peu plus et je reviens vers toi
Amicalement
Alain
Bonsoir, je reviens encore avec mon pb de PasteSpecial qui survient lorsque je change de feuille et en plus, cela bloque mes menus déroulants dans la feuille "Pilotes". Je ne suis pas fortiche en VBA.
 

AtTheOne

XLDnaute Impliqué
Supporter XLD
Bonsoir à toutes & à tous, bonsoir @GUERET
Les 2 problèmes sont différents
cela bloque mes menus déroulants dans la feuille "Pilotes"
Cela provient du fait que tu supprimes toutes les shapes de la feuille "Pilotes" (Excel crée des shapes DropDown pour les listes déroulantes des validations).
Contentons nous de ne supprimer que les images :
VB:
    ...
    For Each sh In Me.Shapes
        If sh.Type = msoPicture Then sh.Delete
    Next
    ...
je reviens encore avec mon pb de PasteSpecial qui survient lorsque je change de feuille
Là, je ne connais pas la cause, cela semble aléatoire.
J'ai remarqué qu'en mode Débug, si on relance la macro à la ligne qui effectue la copie, l'erreur ne se reproduit pas : d'où une tentative de contournement par gestion de l'erreur :
Code:
...
                         Rpt = 0
Répéter:                 sh.Copy
                         Rpt = Rpt + 1
                         If Rpt > 2 Then MsgBox "Echec sur le collage : " & sh.Name: Exit Sub
                         If Rpt = 2 Then MsgBox "2ème tentative pour " & sh.Name
                         On Error GoTo Répéter
                         Me.Range("A3").Offset(Application.Match(Feuil27.Range("B" & sh.TopLeftCell.Row), Me.Range("B5:B35"), 0), 0).PasteSpecial
                         On Error GoTo 0

...
Le code complet :
VB:
Private Sub Worksheet_Activate()
Dim c As Range, sh As Shape, Nom As String, Rpt As Byte

     Application.ScreenUpdating = False
     For Each sh In Me.Shapes
          If sh.Type = msoPicture Then sh.Delete
     Next
     For Each sh In Feuil27.Shapes
          If sh.Type = msoPicture Then
               If sh.TopLeftCell.Column = 4 Then
                    If Not IsError(Application.Match(Feuil27.Range("B" & sh.TopLeftCell.Row), Me.Range("B5:B35"), 0)) Then
                         Nom = sh.Name
                         Rpt = 0
Répéter:                 sh.Copy
                         Rpt = Rpt + 1
                         If Rpt > 2 Then MsgBox "Echec sur le collage : " & sh.Name: Exit Sub
                         If Rpt = 2 Then MsgBox "2ème tentative pour " & sh.Name
                         On Error GoTo Répéter
                         Me.Range("A3").Offset(Application.Match(Feuil27.Range("B" & sh.TopLeftCell.Row), Me.Range("B5:B35"), 0), 0).PasteSpecial
                         On Error GoTo 0
                         Selection.Height = Selection.TopLeftCell.Height
                         Selection.Name = Nom
                    End If
               End If
          End If
     Next
     Application.ScreenUpdating = True
End Sub

Remarque : J'ai nommé les photos de la feuille Photos à l'aide d'une macro dans le module4 .
Code:
Sub NommerPhotos()

     For Each sh In Feuil27.Shapes
          With sh
          Select Case True
               Case .TopLeftCell.Column = 4 And .TopLeftCell.Row < 35
                    .Name = "Pilote|" & Feuil27.Cells(.TopLeftCell.Row, 2)
               Case .TopLeftCell.Column = 8 And .TopLeftCell.Row < 16
                    .Name = "Moto|" & Feuil27.Cells(.TopLeftCell.Row, 6)
               Case .TopLeftCell.Column = 11 And .TopLeftCell.Row < 16
                    .Name = "Logo|" & Feuil27.Cells(.TopLeftCell.Row, 10)
               Case Else
          End Select
          End With
     Next sh
    
End Sub

et une autre pour la dimension des photos
Code:
Sub PositionTaille()

     Largeur = Feuil27.[L1].Left - Feuil27.[K1].Left - 4
     Hauteur = Feuil27.[D5].Top - Feuil27.[D4].Top - 4
     For Each sh In Feuil27.Shapes
          With sh
               If .TopLeftCell.Column = 4 Or .TopLeftCell.Column = 8 Or .TopLeftCell.Column = 11 Then
                    .Top = .TopLeftCell.Top + 2
                    .Left = .TopLeftCell.Left + 2
                    .Width = Largeur
                    If .Height > Hauteur Then .Height = Hauteur
               End If
          End With
     Next sh

End Sub

Voilà j'espère que cela réglera ton problème
Amicalement
Alain
 

GUERET

XLDnaute Occasionnel
Bonsoir à toutes & à tous, bonsoir @GUERET
Les 2 problèmes sont différents

Cela provient du fait que tu supprimes toutes les shapes de la feuille "Pilotes" (Excel crée des shapes DropDown pour les listes déroulantes des validations).
Contentons nous de ne supprimer que les images :
VB:
    ...
    For Each sh In Me.Shapes
        If sh.Type = msoPicture Then sh.Delete
    Next
    ...

Là, je ne connais pas la cause, cela semble aléatoire.
J'ai remarqué qu'en mode Débug, si on relance la macro à la ligne qui effectue la copie, l'erreur ne se reproduit pas : d'où une tentative de contournement par gestion de l'erreur :
Code:
...
                         Rpt = 0
Répéter:                 sh.Copy
                         Rpt = Rpt + 1
                         If Rpt > 2 Then MsgBox "Echec sur le collage : " & sh.Name: Exit Sub
                         If Rpt = 2 Then MsgBox "2ème tentative pour " & sh.Name
                         On Error GoTo Répéter
                         Me.Range("A3").Offset(Application.Match(Feuil27.Range("B" & sh.TopLeftCell.Row), Me.Range("B5:B35"), 0), 0).PasteSpecial
                         On Error GoTo 0

...
Le code complet :
VB:
Private Sub Worksheet_Activate()
Dim c As Range, sh As Shape, Nom As String, Rpt As Byte

     Application.ScreenUpdating = False
     For Each sh In Me.Shapes
          If sh.Type = msoPicture Then sh.Delete
     Next
     For Each sh In Feuil27.Shapes
          If sh.Type = msoPicture Then
               If sh.TopLeftCell.Column = 4 Then
                    If Not IsError(Application.Match(Feuil27.Range("B" & sh.TopLeftCell.Row), Me.Range("B5:B35"), 0)) Then
                         Nom = sh.Name
                         Rpt = 0
Répéter:                 sh.Copy
                         Rpt = Rpt + 1
                         If Rpt > 2 Then MsgBox "Echec sur le collage : " & sh.Name: Exit Sub
                         If Rpt = 2 Then MsgBox "2ème tentative pour " & sh.Name
                         On Error GoTo Répéter
                         Me.Range("A3").Offset(Application.Match(Feuil27.Range("B" & sh.TopLeftCell.Row), Me.Range("B5:B35"), 0), 0).PasteSpecial
                         On Error GoTo 0
                         Selection.Height = Selection.TopLeftCell.Height
                         Selection.Name = Nom
                    End If
               End If
          End If
     Next
     Application.ScreenUpdating = True
End Sub

Remarque : J'ai nommé les photos de la feuille Photos à l'aide d'une macro dans le module4 .
Code:
Sub NommerPhotos()

     For Each sh In Feuil27.Shapes
          With sh
          Select Case True
               Case .TopLeftCell.Column = 4 And .TopLeftCell.Row < 35
                    .Name = "Pilote|" & Feuil27.Cells(.TopLeftCell.Row, 2)
               Case .TopLeftCell.Column = 8 And .TopLeftCell.Row < 16
                    .Name = "Moto|" & Feuil27.Cells(.TopLeftCell.Row, 6)
               Case .TopLeftCell.Column = 11 And .TopLeftCell.Row < 16
                    .Name = "Logo|" & Feuil27.Cells(.TopLeftCell.Row, 10)
               Case Else
          End Select
          End With
     Next sh
   
End Sub

et une autre pour la dimension des photos
Code:
Sub PositionTaille()

     Largeur = Feuil27.[L1].Left - Feuil27.[K1].Left - 4
     Hauteur = Feuil27.[D5].Top - Feuil27.[D4].Top - 4
     For Each sh In Feuil27.Shapes
          With sh
               If .TopLeftCell.Column = 4 Or .TopLeftCell.Column = 8 Or .TopLeftCell.Column = 11 Then
                    .Top = .TopLeftCell.Top + 2
                    .Left = .TopLeftCell.Left + 2
                    .Width = Largeur
                    If .Height > Hauteur Then .Height = Hauteur
               End If
          End With
     Next sh

End Sub

Voilà j'espère que cela réglera ton problème
Amicalement
Alain
Sitôt dit sitôt fait et encore merci pour cette aide
Cordialement
 

Discussions similaires

Réponses
14
Affichages
354
Compte Supprimé 979
C

Statistiques des forums

Discussions
311 711
Messages
2 081 792
Membres
101 817
dernier inscrit
carvajal