XL 2019 ActiveSheet.Paste ne fonctionne pas

eduraiss

XLDnaute Accro
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
 

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:

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
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 :
 

Pièces jointes

  • Test eric 5 (Code Compresser).xlsm
    50.1 KB · Affichages: 5

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
 

eduraiss

XLDnaute Accro
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
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 925
Membres
101 841
dernier inscrit
ferid87