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

 

[eduraiss]

ça bug toujours
Il est ecrit Factive.paste dasn le code
J'ai mis Active.paste

 

[eduraiss]

Desolé
Factive.paste bug

 

[laurent950]

Il est ecrit Factive.paste dasn le code

avec le code que je vous ai donner a qu'elle ligne cela bloque ?

 

[eduraiss]

avec le code que je vous ai donner a qu'elle ligne cela bloque ?

FGroupSemaine.Shapes("AutoShape 13").Copy
Factive.Paste
Selection.Top = Factive.Range(colonnes(n) & m).Top

Factive.Paste est en jaune

 

[job75]

Bonjour eduraiss, laurent950,

Une solution assez classique dans le fichier joint :

Sub Images()
Dim F As Worksheet, d As Object, c As Range, s As Shape, sc&
Set F = Feuil2 'CodeName, à adapter
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
For Each c In F.UsedRange.SpecialCells(xlCellTypeConstants)
    If c.Column = 14 Then d(c.Value) = "AutoShape 13"
    If c.Column = 15 Then d(c.Value) = "Oval 93"
Next c
With ActiveSheet
    For Each s In .Shapes
        If s.Name Like "AutoShape*" Or s.Name Like "Oval*" Then s.Delete
    Next s
    For Each c In .UsedRange.SpecialCells(xlCellTypeConstants)
        If d.exists(c.Value) Then
            F.Shapes(d(c.Value)).Copy
            sc = .Shapes.Count
            Do
                .Paste
                DoEvents
            Loop While .Shapes.Count = sc 'attente de l'exécution
            Selection.Top = c.Top + 2
            Selection.Left = c(1, 2).Left - Selection.Width - 2 'cadrage à droite
        End If
    Next c
    ActiveCell.Activate 'désélectionne l'objet
End With
End Sub

Chez moi sur Excel 2019 aucun problème.

A+

 

[eduraiss]

bonsoir Job75
chez moi
sc = .Shapes.Count
Do
.Paste
DoEvents

Bug sur le .Paste

C'est pas possible

 

[laurent950]

re,
Correction code Poste #15 avec cette ligne corrigé :

FGroupSemaine.Shapes("AutoShape 13").Copy
'Factive.Paste
Factive.Paste Destination:=Factive.Cells(1, 1)
Selection.Top = Factive.Range(colonnes(n) & m).Top

Avec cette ligne : Factive.Paste Destination:=Factive.Cells(1, 1)

 

[eduraiss]

bug sur la ligne
Factive.Paste Destination:=Factive.Cells(1, 1)

 

[job75]

J'ai testé plusieurs dizaines de fois ma macro du post #20 :

- la boucle Do/Loop s'exécute toujours une seule fois, elle est donc inutile chez moi

- il arrive (rarement) qu'il y ait un bug sur F.Shapes(d(c.Value)).Copy.

 

[laurent950]

Re,
Voila la solution, avec une variable de type objet c'est plus simple.
Code Corrigé en Poste #15

Explication ci-dessous

On encapsule l'ojet dans cette variable
         Set sh = FGroupSemaine.Shapes("Oval 93")
donc on la duplique
sh.Duplicate
On la coupe ---> comme copier coller mais là c'est couper coller
sh.Cut
puis on la colle
Factive.Paste
sur la feuille active

Laurent

 

[job75]

Avec ce fichier (2) plus de souci, ce sont les cellules sources N2 et O2 qui sont copiées/collées :

Sub Images()
Dim F As Worksheet, d As Object, c As Range, s As Shape, mem
Set F = Feuil2 'CodeName, à adapter
Application.ScreenUpdating = False
Application.CopyObjectsWithCells = True 'au cas où...
F.DrawingObjects.Placement = 2 'Déplacer sans dimensionner avec les cellules
Set d = CreateObject("Scripting.Dictionary")
For Each c In F.UsedRange.SpecialCells(xlCellTypeConstants)
    If c.Column = 14 Then Set d(c.Value) = F.Range("N2") 'cellule à adapter
    If c.Column = 15 Then Set d(c.Value) = F.Range("O2") 'cellule à adapter
Next c
With ActiveSheet
    For Each s In .Shapes
        If s.Name Like "AutoShape*" Or s.Name Like "Oval*" Then s.Delete
    Next s
    For Each c In .UsedRange.SpecialCells(xlCellTypeConstants)
        If d.exists(c.Value) Then
            mem = c
            d(c.Value).Copy c 'copie/colle la cellule avec son objet
            c = mem
        End If
    Next c
End With
End Sub

 

[eduraiss]

Re bonsoir le forum
Et à job75 et laurent950
Là je ne peux pas tester vos codes, je suis chez moi et en effet cela fonctionne, mais sur l'ordinateur de mon travail à voir
Seulement mardi je pourrais les tester
Je tenais quoi que cela donne, vous remercier de votre implication à solutionner mon problème
Je ne manquerais pas de faire un retour

en vous remerciant encore
Bien cordialement,

 

[job75]

Pour terminer, fichier (2 bis) avec les objets cadrés à droite.

Pour cela il faut que les colonnes des noms aient la même largeur, ici 20, dans les 2 feuilles.

 

[laurent950]

Bonsoir Job75,
Le code a Job75 est le meilleur donc a adopter. Félicitation Job75
Laurent

 

[eduraiss]

Re job75
Merci encore
juste un truc si l on prend l'exemple de DUSSUTOUR il est positionné en secouriste et en hygiène
Mais il reçois qu'un seul symbole