XL 2019 ActiveSheet.Paste ne fonctionne pas

[eduraiss]

Bonjour le forum

Activeseeht.paste ne fonctionne pas voici le code
J'ai changé de version excel, le fichier était en 97 2003 il est maintenant en xlsm, avant pas de soucis

voici le code
Sub autoshape()

For n = ActiveSheet.Shapes.Count To 1 Step -1
If InStr(ActiveSheet.Shapes(n).Name, "Oval") <> 0 Or InStr(ActiveSheet.Shapes(n).Name, "AutoShape") <> 0 Then
ActiveSheet.Shapes(n).Delete
End If
Next n

colonnes = Array("B", "C", "E", "G", "I", "J")

For n = LBound(colonnes) To UBound(colonnes)
For m = 1 To 149
If Range(colonnes(n) & m) <> "" Then
If InStr(Range(colonnes(n) & m), "?") = 0 Then

Set c = Sheets("CODEDATE").Range("N3:W1000").Find(Range(colonnes(n) & m), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do

Select Case c.Column
Case 14
Sheets("CODEDATE").Shapes("Oval 10").Copy
Case 15
Sheets("CODEDATE").Shapes("Oval 94").Copy
Case 16
Sheets("CODEDATE").Shapes("Oval 95").Copy
Case 17
Sheets("CODEDATE").Shapes("Oval 96").Copy
Case 18
Sheets("CODEDATE").Shapes("Oval 97").Copy
Case 19
Sheets("CODEDATE").Shapes("Oval 98").Copy
Case 20
Sheets("CODEDATE").Shapes("Oval 99").Copy
Case 21
Sheets("CODEDATE").Shapes("Oval 100").Copy

End Select

ActiveSheet.Paste
If c.Column < 22 Then
Selection.Top = Range(colonnes(n) & m).Top + 2
Selection.Left = Range(colonnes(n) & m).Left + (c.Column - 14) * 8 + 2
Else

End If
Set c = Sheets("CODEDATE").Cells.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End If
End If
Next m
Next n
Range("A1").Select

End Sub

Merci de votre aide

 

[job75]

Bonsoir eduraiss,

Sans fichier joint difficile de vous aider.

Mais après ActiveSheet.Paste ajoutez la ligne MsgBox "a" ce message apparaît-il ?

A+

 

[Staple1600]

Bonsoir le fil, eduraiss, job75

eduraiss
Il fallait attendre le 14 mars (pour fêter l'anniversaire de ta question 😉

https://www.excel-downloads.com/thr...sse-worsheet-a-echoue.20006578/#post-20048957

 

[eduraiss]

bonsoir le forum
Bonsoir job75 ET staple1600

En effet j'avais eu un problème sur le même sujet et je n'avais pas eu de réponses
Mais cela a fonctionner quand même avec cette macro
mais en changeant de version soit en 2019 alors là ça ne fonctionne plus du tout
Je m'excuse de revenir a la charge mais bon
Merci

 

[eduraiss]

j'essais demain job75, je n'ai pas le fichier chez moi

 

[Staple1600]

Re

eduraiss
Est-ce que par hasard, le fichier de la question de 2016

https://www.excel-downloads.com/thr...sse-worsheet-a-echoue.20006578/#post-20048959

Se rapproche de celui que tu utilises actuellement ?

 

[eduraiss]

Re
oui le fichier est exactement le même

 

[job75]

Re, salut JM,

Sur les dernières versions d'excel il faut attendre que ActiveSheet.Paste s'exécute.

Alors dans la macro remplacez la ligne ActiveSheet.Paste par ces 5 lignes :

sc = ActiveSheet.Shapes.Count
Do
    ActiveSheet.Paste
    DoEvents
Loop While ActiveSheet.Shapes.Count = sc

A+

 

[eduraiss]

Re

merci job75 j'essais cela demain
merci encore
Cordialement,

 

[job75]

J'ai ajouté DoEvents dans le code précédent.

 

[eduraiss]

Bonjour le forum
Bonjour job75
J'ai essayer de remplacer mais cela ne fonctionne pas
Merci

 

[eduraiss]

Re bonjour le forum

Je joins un fichier ou ActiveSheet.Paste bug
Impossible de m'en sortir, depuis que je suis passé sous excel 2019

Merci de votre aide

 

[laurent950]

Bonsoir votre code fonctionne bien !

 

[eduraiss]

Bonsoir Laurent950
c'est bien là mon problème, c'est que depuis que j'ai changé de mon office pour 2019 cela ne fonctionne plus
soit il manque une activation de quelque chose , enfin je ne sais pas
Merci encore

 

[laurent950]

Re,
Essaie avec cette correction,

Sub test()
Dim Factive As Worksheet
Set Factive = Worksheets(ActiveSheet.Name)
Dim FGroupSemaine As Worksheet
Set FGroupSemaine = Worksheets("Groupe semaine")
Dim sh As Shape

For n = Factive.Shapes.Count To 1 Step -1
  If InStr(Factive.Shapes(n).Name, "Oval") <> 0 Or InStr(Factive.Shapes(n).Name, "AutoShape") <> 0 Then
    Factive.Shapes(n).Delete
  End If
Next n

Dim colonnes As Variant
colonnes = Array("C", "E", "G")
For n = LBound(colonnes) To UBound(colonnes)
  For m = 1 To Factive.Range(colonnes(n) & Factive.Range(colonnes(n) & 65536).End(xlUp).Row).Row
   If Factive.Range(colonnes(n) & m) <> "" Then
    If InStr(Factive.Range(colonnes(n) & m), "?") = 0 Then
     Set c = FGroupSemaine.Cells.Find(Factive.Range(colonnes(n) & m), LookIn:=xlValues, lookat:=xlWhole)
     
       If Not c Is Nothing Then
            firstAddress = c.Address
        Do
         'MsgBox (c.Value & " " & c.Address)
       If c.Column = 14 Then
         Set sh = FGroupSemaine.Shapes("AutoShape 13")
         sh.Duplicate: sh.Cut: Factive.Paste
         Selection.Top = Factive.Range(colonnes(n) & m).Top
         Selection.Left = Factive.Range(colonnes(n) & m).Left
       End If
       If c.Column = 15 Then
         Set sh = FGroupSemaine.Shapes("Oval 93")
         sh.Duplicate: sh.Cut: Factive.Paste
         Selection.Top = Factive.Range(colonnes(n) & m).Top
         Selection.Left = Factive.Range(colonnes(n) & m).Left + Factive.Range(colonnes(n) & m).Width - Selection.Width
       End If
       Set c = FGroupSemaine.Cells.FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
      End If
    End If
   End If
  Next m
Next n
Factive.Range("A1").Select
End Sub