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
 

patricktoulon

XLDnaute Barbatruc
bien vu job75 le CopyObjectsWithCells
ca plait beaucoup a Laurent :p :p :p
il souhaiterait comprendre comment en copiant o2 ou N2 et en le collant dans la cellules itérées dans ta boucle sur la sheets2 on arrive a garder la valeur et on a bien le shapes collé ;););)

perso moi ce que je préfère c'est le "au cas ou...." ;) ;)
 

patricktoulon

XLDnaute Barbatruc
si tu veux les s deux cote a cote avec le model de Job75 comme ca devrait etre le cas avec "DUSSUTOUR C" le voici modifié
VB:
Option Explicit

Sub Images()
    Dim F As Worksheet, d As Object, c As Range, s As Shape, mem
    Dim elem, rond
    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("14" & c.Value) = F.Range("N2")    'cellule à adapter
        If c.Column = 15 Then Set d("15" & c.Value) = F.Range("O2")    'cellule à adapter
    Next c
    For Each elem In d
        Debug.Print elem; "  "; TypeName(d(elem))
    Next
    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)
            rond = False
            If d.exists("15" & c.Value) Then
                mem = c
                d("15" & c.Value).Copy c    'copie/colle la cellule avec son objet
                c = mem
                rond = True
            End If

            If d.exists("14" & c.Value) Then
                With Feuil2.Shapes("AutoShape 13")
                    If rond = True Then .Left = Feuil2.[O2].Left - 30 Else Feuil2.Shapes("AutoShape 13").Left = Feuil2.[O2].Left - 20
                End With
                mem = c
                d("14" & c.Value).Copy c    'copie/colle la cellule avec son objet
                c = mem
            End If
      Next c
    End With
End Sub

vraiment bien vu Job75 ;) ;)

j'imagine les yeux de Laurent gonfler dans leurs orbites :p :p :p
j'ai mis pour la demo la lecture du dico en debug
ca faciltera la compréhension de ce que fait
l'option CopyObjectsWithCells avec d("14" & c.Value).copy/ mem=c / paste / c=mem

cette methode a pour avantage de pourvoir utiliser copy destination:= une range vers un range(chose impossible avec une shapes )
demo
demo3.gif


bon je met le fichier " au cas ou...." :p :p :p :p

VOIR MÉTHODE AMÉLIORÉE EN POST 36 PAR JOB75 AVEC UNE CELLULE DE GARDE SUPPLÉMENTAIRE ET LE CLASSEMENT DANS LE DICO EN FONCTION DU COUNTIFF
 

Pièces jointes

  • eric 5(2 bis) modifié V pat .xlsm
    28.5 KB · Affichages: 6
Dernière édition:

laurent950

XLDnaute Accro
Re,
Ha ha ha j'ai mal fait mon Job... Hi Hi Hi C'est Job75 qui a fait la procédure j'avais pas mais lunette hi hi hi... toutes mes félicitaion von à Job75... et en deuxiéme prix à... (Patrick qui a su déchiffré se magnique code... c'est un véritable "champollion" :p :p :p et moi j'ai les yeux qui sont partout comme un vrais camélion hi hi hi... je mis perd ha ha ha mais magnifique cette procédure Job75 vous êtes au top
Laurent
 
Dernière édition:

job75

XLDnaute Barbatruc
Salut patricktoulon,

Bah pour le cas doublon de DUSSUTOUR C ce n'est pas bien sorcier.

Il suffit de prévoir la cellule source P2 avec 2 objets, voyez ce fichier (3) :
VB:
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 Application.CountIf(F.UsedRange, c) = 1 Then
        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
    Else
        Set d(c.Value) = F.Range("P2") 'doublon, cellule à adapter
    End If
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
 

Pièces jointes

  • eric 5(3).xls
    58 KB · Affichages: 6

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
 

Pièces jointes

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

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.
 

Pièces jointes

  • eric 5(4).xls
    57 KB · Affichages: 10

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 940
Membres
101 845
dernier inscrit
annesof