XL 2019 ActiveSheet.Paste ne fonctionne pas

eduraiss · 25 Février 2020

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 · 25 Février 2020

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 · 25 Février 2020

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 · 25 Février 2020

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 · 25 Février 2020

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

Staple1600 · 25 Février 2020

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 · 25 Février 2020

Re
oui le fichier est exactement le même

job75 · 25 Février 2020

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 :

VB:

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

A+

eduraiss · 25 Février 2020

Re

merci job75 j'essais cela demain
merci encore
Cordialement,

job75 · 25 Février 2020

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

eduraiss · 26 Février 2020

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

eduraiss · 26 Février 2020

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 · 26 Février 2020

Bonsoir votre code fonctionne bien !

eduraiss · 26 Février 2020

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 · 26 Février 2020

Re,
Essaie avec cette correction,

VB:

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

XL 2019 ActiveSheet.Paste ne fonctionne pas

eduraiss

XLDnaute Accro

job75

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

eduraiss

XLDnaute Accro

eduraiss

XLDnaute Accro

Staple1600

XLDnaute Barbatruc

eduraiss

XLDnaute Accro

job75

XLDnaute Barbatruc

eduraiss

XLDnaute Accro

job75

XLDnaute Barbatruc

eduraiss

XLDnaute Accro

eduraiss

XLDnaute Accro

Pièces jointes

laurent950

XLDnaute Barbatruc

eduraiss

XLDnaute Accro

laurent950

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

XL 2019 ActiveSheet.Paste ne fonctionne pas

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Accro

Pièces jointes

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Privacy & Transparency

Privacy & Transparency