XL 2019 PasteSpecial

GUERET · 30 Avril 2022

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

Transfer not found - TransferNow

Click to download the files for this transfer with TransferNow

www.transfernow.net

AtTheOne · 30 Avril 2022

Bonsoir à toutes & à tous, bonsoir @GUERET

GUERET à dit:
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 · 30 Avril 2022

Re,
la photo en D28 est en fait celle de michele pirro

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

GUERET · 30 Avril 2022

À force d'avoir le nez dessus, je 'ai rien vu concernant les photos. Erreur réparé derechef.
merci pour votre aide.

GUERET · 30 Avril 2022

AtTheOne à dit:
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 · 4 Mai 2022

AtTheOne à dit:
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 · 4 Mai 2022

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

GUERET à dit:
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
    ...

GUERET à dit:
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 · 5 Mai 2022

AtTheOne à dit:

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

AtTheOne · 6 Mai 2022

Bonjour @GUERET
Merci pour le retour, si cela fonctionne, pense à marquer le post#7 comme étant la solution
Amicalement
Alain

GUERET · 6 Mai 2022

AtTheOne à dit:
Bonjour @GUERET
Merci pour le retour, si cela fonctionne, pense à marquer le post#7 comme étant la solution
Amicalement
Alain

Ça marche et encore merci Alain

XL 2019 PasteSpecial

GUERET

XLDnaute Occasionnel

Transfer not found - TransferNow

AtTheOne

XLDnaute Accro

AtTheOne

XLDnaute Accro

GUERET

XLDnaute Occasionnel

GUERET

XLDnaute Occasionnel

GUERET

XLDnaute Occasionnel

AtTheOne

XLDnaute Accro

GUERET

XLDnaute Occasionnel

AtTheOne

XLDnaute Accro

GUERET

XLDnaute Occasionnel

Discussions similaires