XL 2019 ActiveSheet.Paste ne fonctionne pas

laurent950

XLDnaute Accro
juste pour Patrick avec le fichier

Je comprend pas cette ligne
* ---> Factive.Shapes.Range(Array(s.Name))

cela fonctionne comme cela ci-dessous (dans le code plus bas)
VB:
                    If item1.Column = 14 Then
                        Set s = sh(1).Duplicate
                        s.Name = "x": s.Copy: Factive.Paste
                        With ActiveSheet.Shapes.Range(Array(s.Name))
                            .Top = item2.Top
                            .Left = item2.Left
                            .Name = sh(1).Name
                        End With
Impossible a faire fonctionner de cette facon !?
VB:
                        Set s = sh(2).Duplicate
                        s.Name = "x": s.Copy: Factive.Paste
                        ' Fonctionne pas
                        With s 
                            .Select
                            .Top = item2.Top
                            .Left = item2.Left + item2.Width - .Width
                            .Name = sh(2).Name
                        End With
enfin le code ci-dessous ! que je suis arrivé a compiler avec des doutes !

VB:
Sub testbisNettoyer()
' ********************************************************************
Dim FGroupSemaine As Worksheet
    Set FGroupSemaine = Worksheets("Groupe semaine")
Dim Rg1 As Range
    Set Rg1 = Union(FGroupSemaine.Range(FGroupSemaine.Cells(1, 14), FGroupSemaine.Cells(FGroupSemaine.Cells(65536, 14).End(xlUp).Row, 14)), FGroupSemaine.Range(FGroupSemaine.Cells(1, 15), FGroupSemaine.Cells(FGroupSemaine.Cells(65536, 15).End(xlUp).Row, 15)))
Dim item1 As Range
Dim sh(1 To 2) As Shape
Set sh(1) = FGroupSemaine.Shapes("AutoShape 13")
Set sh(2) = FGroupSemaine.Shapes("Oval 93")
' ********************************************************************
Dim Factive As Worksheet
    Set Factive = Worksheets(ActiveSheet.Name)
Dim Rg2 As Range
    Set Rg2 = Union(Factive.Range(Factive.Cells(1, 3), Factive.Cells(Factive.Cells(65536, 3).End(xlUp).Row, 3)), Factive.Range(Factive.Cells(1, 5), Factive.Cells(Factive.Cells(65536, 5).End(xlUp).Row, 5)), Range(Factive.Cells(1, 7), Factive.Cells(Factive.Cells(65536, 7).End(xlUp).Row, 7)))
' *******************************************************************

Dim s As Shape
For Each s In Factive.Shapes
    If s.Name = sh(1).Name Or s.Name = sh(2).Name Then
        s.Delete
    End If
Next s

Dim item2 As Range
    For Each item2 In Rg2
        If item2.Value <> Empty Then
            For Each item1 In Rg1
                If item1.Value = item2.Value Then
                    If item1.Column = 14 Then
                        Set s = sh(1).Duplicate
                        s.Name = "x": s.Copy: Factive.Paste
                        With Factive.Shapes.Range(Array(s.Name))
                            .Top = item2.Top
                            .Left = item2.Left
                            .Name = sh(1).Name
                        End With
                    ElseIf item1.Column = 15 Then
                        Set s = sh(2).Duplicate
                        s.Name = "x": s.Copy: Factive.Paste
                        With Factive.Shapes.Range(Array(s.Name))
                            .Top = item2.Top
                            .Left = item2.Left + item2.Width - .Width
                            .Name = sh(2).Name
                        End With
                    End If
                End If
         Next item1
        End If
    Next item2
End Sub
le fichier ci-joint
 

Fichiers joints

patricktoulon

XLDnaute Barbatruc
re
Set s = sh(2).Duplicate
s.Name = "x": s.Copy: Factive.Paste
' Fonctionne pas
' With s 's c'est le duplicate pas la copie que tu viens de coller !!!!!!!!!!!!!!!!!!!!!!
with selection !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
.Select
.Top = item2.Top
.Left = item2.Left + item2.Width - .Width
.Name = sh(2).Name
End With


je te l'ai repris j'ai laissé la version avec duplicate si tu y tiens
VB:
Sub testbisNettoyer()
' ********************************************************************
    Dim FGroupSemaine As Worksheet
    Set FGroupSemaine = Worksheets("Groupe semaine")
    Dim Rg1 As Range
    Set Rg1 = Union(FGroupSemaine.Range(FGroupSemaine.Cells(1, 14), FGroupSemaine.Cells(FGroupSemaine.Cells(65536, 14).End(xlUp).Row, 14)), FGroupSemaine.Range(FGroupSemaine.Cells(1, 15), FGroupSemaine.Cells(FGroupSemaine.Cells(65536, 15).End(xlUp).Row, 15)))
    Dim item1 As Range
    Dim sh(1 To 2) As Shape
    Set sh(1) = FGroupSemaine.Shapes("AutoShape 13")
    Set sh(2) = FGroupSemaine.Shapes("Oval 93")
    ' ********************************************************************
    Dim Factive As Worksheet
    Set Factive = Worksheets(ActiveSheet.Name)
    Dim Rg2 As Range
    Set Rg2 = Union(Factive.Range(Factive.Cells(1, 3), Factive.Cells(Factive.Cells(65536, 3).End(xlUp).Row, 3)), Factive.Range(Factive.Cells(1, 5), Factive.Cells(Factive.Cells(65536, 5).End(xlUp).Row, 5)), Range(Factive.Cells(1, 7), Factive.Cells(Factive.Cells(65536, 7).End(xlUp).Row, 7)))
    ' *******************************************************************
    Dim s As Shape
    For Each s In Factive.Shapes
        If s.Name = sh(1).Name Or s.Name = sh(2).Name Then
            s.Delete
        End If
    Next s
    Dim item2 As Range
    For Each item2 In Rg2
        If item2.Value <> Empty Then
            For Each item1 In Rg1
                If item1.Value = item2.Value Then
                    If item1.Column = 14 Then
                        'With sh(2).Duplicate: .Copy: Factive.Paste: .Delete: Set shap = Selection: End With
                        With sh(1): .Copy: Factive.Paste: Set shap = Selection: End With
                        With shap
                            .Name = 15 & "-" & item2.Row
                            .Top = item2.Top
                            .Left = item2.Left
                        End With
                    ElseIf item1.Column = 15 Then
                        'With sh(2).Duplicate: .Copy: Factive.Paste: .Delete: Set shap = Selection: End With
                        With sh(2): .Copy: Factive.Paste: Set shap = Selection: End With
                        With shap
                            .Name = 15 & "-" & item2.Row
                            .Top = item2.Top
                            .Left = item2.Left + item2.Width - .Width
                        End With
                    End If
                End If
            Next item1
        End If
    Next item2
End Sub
mais quand tu parle de range évite de parler en "item" parle en "cells" se sera plus clair pour tout le monde et je nome différemment les shapes aussi ;) c'est pas très fonctionnel des shapes de même nom
cela dit la méthode dico est beaucoup mieux
et même sans dico il y a largement plus simple
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour le fil, le forum,

Application.CountIf prend du temps, cette macro du fichier (4) est plus rapide :
VB:
Sub Images()
Dim d As Object, c As Range, s As Shape, mem
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.CopyObjectsWithCells = True 'au cas où...
With Feuil2 'CodeName, à adapter
    .DrawingObjects.Placement = 2 'Déplacer sans dimensionner avec les cellules
    For Each c In .UsedRange.SpecialCells(xlCellTypeConstants, 2)
        If d.exists(c.Value) Then
            Set d(c.Value) = .Range("P2") 'doublon, cellule à adapter
        Else
            If c.Column = 14 Then Set d(c.Value) = .Range("N2") 'cellule à adapter
            If c.Column = 15 Then Set d(c.Value) = .Range("O2") 'cellule à adapter
        End If
    Next c
End With
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, 2)
        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
Bonne journée.
 

Fichiers joints

job75

XLDnaute Barbatruc
Avec ma méthode si les objets ne sont pas recopiés correctement là c'est vraiment un bug d'Excel.
 

laurent950

XLDnaute Accro
Bonjour,
#Job75 votre code est vraiment Magnifique et le meilleur de très loin.
#PatrickToulon Aussi un très très grand Merci à Patricktoulon qui m'aide beaucoup et avec qui j'apprend aussi.

Donc Patricktoulon (Macro VBA en Poste #42) :
* J'ai une intérogation avec cette variable : shap

La Fenêtre espion indique :
A) (Sans avoir placé en entête) OPTION EXPLICIT :
* shap ---->> Variant/Object/Rectangle
1582801696095.png

B) (Avec placé en entête) OPTION EXPLICIT :
* shap ---->> Variable non définit
En conclusion :
* dim shap as shape / Incompatibilité de type : avec --->> (Set shap = Selection)
* dim shap as shapes / Incompatibilité de type : avec --->> (Set shap = Selection)
Essaie avec :
* dim shap as Variant
* shap ---->>Variant/Object/Rectangle
1582801414019.png

* dim shap as Object
* shap ---->> Obeject/Rectangle
1582801466026.png
* dim shap as Rectangle
Ps : Etrange cela fonctionne !
* shap ---->> Rectangle/Rectangle
1582801521458.png
******************************************************************************************************
Pourquoi cela ne fonctionne pas avec :
* dim shap as shape / Incompatibilité de type : avec --->> (Set shap = Selection)
* dim shap as shapes / Incompatibilité de type : avec --->> (Set shap = Selection)

Si vous avez une réponse à mon intérogation je serais très content.

Ps : Un très grand Merci à PatrickToulon, et félicitation à Job75 pour son merveilleux Code en #Poste 43

Laurent
 
Dernière édition:

job75

XLDnaute Barbatruc
Pourquoi cela ne fonctionne pas avec :
* dim shap as shape / Incompatibilité de type : avec --->> (Set shap = Selection)
Pourquoi vouloir être plus royaliste que le roi ? Puisqu'on vous dit que ça ne va pas utilisez :
VB:
Dim shap as Object
 

laurent950

XLDnaute Accro
Pourquoi vouloir être plus royaliste que le roi ? Puisqu'on vous dit que ça ne va pas utilisez :
Donc en conclusion vous ne savez pas non plus Job75 :
* dim shap as Object
* shap ---->> Obeject/Rectangle
Cela ne génére pas (Un Objet Shapes) puis aucune proposition des Méthode et propriétés de cet obejet shap générer avec (dim shap as Object)
donc :
shap. Rien de proposé après le Point qui suit l'objet (shap)
C'est juste histoire de savoir et comprendre et en aucun cas "être plus royaliste que le roi"
Ont sait ou Ont ne sait Pas ?

En tous cas merci Job75 cela conforte ma premiére idée et donc que c'est bien complexe ce model Objet Excel VBA.

Laurent
 
Dernière édition:

laurent950

XLDnaute Accro
Il est évident que Selection n'est pas une Shape, un point c'est tout !
Oui effectivement Job75 mais alors comment cela se fait t'il que l'ont ne puisse pas passer cette variable avec
dim shap as shape
tous simplement c'est incroyable de passer par
dim shap as object ?

C'est pour apprendre (des cas écoles comme ont dit) et ma culture personel Job75
 

job75

XLDnaute Barbatruc
Ce que je constate c'est que laurent950 et patricktoulon adorent multiplier les posts même quand ils n'ont plus rien à voir avec la question initiale.
 

laurent950

XLDnaute Accro
Bon j'ai enfin trouvé

https://www.thespreadsheetguru.com/the-code-vault/vba-set-shape-variable-to-selected-shape

Essaie avec :
* dim shap as Shape
* shap ---->>Shape/Shape
* pour : Set shap = ActiveSheet.Shapes(Selection.Name)
1582813970212.png
Modification du code de avec l'instruction ci-dessus de Patricktoulon (Macro VBA en Poste #42) :

Pour Patricktoulon :
j'ai Modifié cela "mais quand tu parle de range évite de parler en "item" parle en "cells" se sera plus clair pour tout le monde"
Dim item1 As Range
Item1 ---> Cells1 ----->>> Dim Cells1 As Range
Dim item2 As Range
Item2 ---> Cells2 ------>>> Dim Cells2 As Range

Le Code : Ci-Dessous (Agrémenté est complété) :
* Module : Module1Patrick
*
Code : testbisNettoyerPatrickToulon
VB:
Option Explicit
Sub testbisNettoyerPatrickToulon()
' ********************************************************************
    Dim FGroupSemaine As Worksheet
    Set FGroupSemaine = Worksheets("Groupe semaine")
    Dim Rg1 As Range
    Set Rg1 = Union(FGroupSemaine.Range(FGroupSemaine.Cells(1, 14), FGroupSemaine.Cells(FGroupSemaine.Cells(65536, 14).End(xlUp).Row, 14)), FGroupSemaine.Range(FGroupSemaine.Cells(1, 15), FGroupSemaine.Cells(FGroupSemaine.Cells(65536, 15).End(xlUp).Row, 15)))
    Dim Cells1 As Range
    Dim sh(1 To 2) As Shape
    Set sh(1) = FGroupSemaine.Shapes("AutoShape 13")
    Set sh(2) = FGroupSemaine.Shapes("Oval 93")
    ' ********************************************************************
    Dim Factive As Worksheet
    Set Factive = Worksheets(ActiveSheet.Name)
    Dim Rg2 As Range
    Set Rg2 = Union(Factive.Range(Factive.Cells(1, 3), Factive.Cells(Factive.Cells(65536, 3).End(xlUp).Row, 3)), Factive.Range(Factive.Cells(1, 5), Factive.Cells(Factive.Cells(65536, 5).End(xlUp).Row, 5)), Range(Factive.Cells(1, 7), Factive.Cells(Factive.Cells(65536, 7).End(xlUp).Row, 7)))
    ' *******************************************************************
    Dim s As Shape
    For Each s In Factive.Shapes
        If s.Name = sh(1).Name Or s.Name = sh(2).Name Then
            s.Delete
        End If
    Next s
    Dim shap As Shape
    Dim Cells2 As Range
    For Each Cells2 In Rg2
        If Cells2.Value <> Empty Then
            For Each Cells1 In Rg1
                If Cells1.Value = Cells2.Value Then
                    If Cells1.Column = 14 Then
                        With sh(1): .Copy: Factive.Paste: Set shap = ActiveSheet.Shapes(Selection.Name): End With
                        With shap
                            .Name = 15 & "-" & Cells2.Row
                            .Top = Cells2.Top
                            .Left = Cells2.Left
                        End With
                    ElseIf Cells1.Column = 15 Then
                        With sh(2): .Copy: Factive.Paste: Set shap = ActiveSheet.Shapes(Selection.Name): End With
                        With shap
                            .Name = 15 & "-" & Cells2.Row
                            .Top = Cells2.Top
                            .Left = Cells2.Left + Cells2.Width - .Width
                        End With
                    End If
                End If
            Next Cells1
        End If
    Next Cells2
End Sub
ps : Code en conclusion du Poste #42 au #52
Et le fichier excel qui Suit :
 

Fichiers joints

job75

XLDnaute Barbatruc
Bah Selection.Name... Il peut y avoir beaucoup de Shapes avec le même nom !!!

Si l'on veut à tout prix déclarer shap As Shape utiliser :
VB:
Dim shap As Shape
For Each shap In ActiveSheet.Shapes
    If shap.Top = Selection.Top And shap.Left = Selection.Left Then Exit For
Next
 

patricktoulon

XLDnaute Barbatruc
je te l'ai dis Laurent ne fait plus tes expériences dans ce post ça fout le bor....
et certains ne manqueront pas de te le sonner et arrete de te disperser
maîtrise une chose après l'autre on a tout le temps
tranquille ;)
 

job75

XLDnaute Barbatruc
C'est sûr, si tout le monde fait comme laurent950 ce forum deviendra illisible.

Pour ce genre d'exercice il y a les MP (conversations).
 

laurent950

XLDnaute Accro
Alors en conclusion un grand Merci à vous deux... je stope l'alimentation de ce Poste mais je suis super content d'avoir apris quelques choses.

Merci, Merci Merci... A Patricktoulon :D et à Job75 :D

The End
 

eduraiss

XLDnaute Impliqué
Bonjour a tous
Bonjour le forum
Je reviens avec vos différentes propositions
Désolé mais aucune ne fonctionne sur mon ordinateur office 2019, chez moi RAS (office 2016)
Donc je ne sais pas ça bug sur paste synthétiquement
Voila, il doit y avoir un truc dans excel qui fait cela, je ne pense pas que cela provienne du code

Merci encore
 

patricktoulon

XLDnaute Barbatruc
re
bonjour tout les participants ont des versions différentes et plusieurs solution proposées fonctionnent chez tout le monde sauf chez toi
donc en effet tu dois avoir un problème de droit ou ton application excel est en vrac
en tout cas on est tous parti avec ton exemple me semble t il
fonctionne sur 2007,2010,2013,2016
les codes utilisé sont basiques et donc compatible toutes versions (me semble t il)et supérieure je serais curieux si MS avait changer cela pour 2019
 

job75

XLDnaute Barbatruc
Désolé mais aucune ne fonctionne sur mon ordinateur office 2019, chez moi RAS (office 2016)
Donc je ne sais pas ça bug sur paste synthétiquement
Bah mes macros des posts #26 #28 #36 #43 n'utilisent pas Paste, les avez-vous testées ?
 

eduraiss

XLDnaute Impliqué
Re bonjour
Bonjour job75
En effet autand pour moi
Je revois un fichier, j'ai rajouter une feuille avec mon besoin reel
est-ce possible de faire quelque chose
Car en effet cela
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas