Microsoft 365 Bouton copier objets vba

kay

XLDnaute Nouveau
Bonjour

Je cherche à créer un bouton permettant de copier des éléments comprenant des objets de type liste déroulante, zone de texte et case à cocher ainsi que des titres, ça se présente comme ceci :

1036399


Merci
 

job75

XLDnaute Barbatruc
Vous ne connaissez pas les boucles For/Next ?

La macro adaptée dans ce fichier (3) :
VB:
Sub Bouton189_Cliquer()
Dim ncopie&, P As Range, decal&, n&, o As OLEObject, c As Range
Application.CopyObjectsWithCells = True
With ActiveSheet
    If .Name = "Definitions" Or .Name = "fx" Or .Name = "Needs" Then Exit Sub
    ncopie = Int(Abs(Val(InputBox("Nombre de fois :", "Copier"))))
    Set P = .[5:9] 'plage à adapter
    decal = P.Rows.Count
    Application.ScreenUpdating = False
    .DrawingObjects.Placement = 2
    For n = 1 To ncopie
        P.Copy P.Offset(n * decal) 'copie les cellules et les contrôles de formulaire
        For Each o In .OLEObjects 'boucle pour copier les contrôles ActiveX
            Set c = o.TopLeftCell
            If Not Intersect(P, c) Is Nothing Then
                With o.Duplicate 'duplication
                    .Left = o.Left
                    .Top = c.Offset(n * decal).Top + o.Top - c.Top
                End With
            End If
    Next o, n
End With
End Sub
A+
 

Pièces jointes

  • Formulaire JDD(3).xlsm
    70.5 KB · Affichages: 10
Dernière édition:

kay

XLDnaute Nouveau
Vous ne connaissez pas les boucles For/Next ?

La macro adaptée dans ce fichier (3) :
VB:
Sub Bouton189_Cliquer()
Dim ncopie&, P As Range, decal&, n&, o As OLEObject, c As Range
Application.CopyObjectsWithCells = True
With ActiveSheet
    If .Name = "Definitions" Or .Name = "fx" Or .Name = "Needs" Then Exit Sub
    ncopie = Int(Abs(Val(InputBox("Nombre de fois :", "Copier"))))
    If ncopie = 0 Then Exit Sub
    Set P = .[5:9] 'plage à adapter
    decal = P.Rows.Count
    Application.ScreenUpdating = False
    .DrawingObjects.Placement = 2
    For n = 1 To ncopie
        P.Copy P.Offset(n * decal) 'copie les cellules et les contrôles de formulaire
        For Each o In .OLEObjects 'boucle pour copier les contrôles ActiveX
            Set c = o.TopLeftCell
            If Not Intersect(P, c) Is Nothing Then
                o.Duplicate.Cut 'duplication et couper
                .Paste 'coller
                With .OLEObjects(.OLEObjects.Count)
                    .Left = o.Left
                    .Top = c.Offset(n * decal).Top + o.Top - c.Top
                End With
            End If
    Next o, n
End With
End Sub
A+
Génial !
Je suis une grande débutante je ne connaissais pas mais ça fait des merveilles
Merci encore pour votre aide !

Bonne soirée
 

kay

XLDnaute Nouveau
Bonjour à tous,

Je reviens sur le sujet.
Le code donné ci-dessus ne permet pas d'ajouter à nouveau des lignes.

Je m'explique :
En cliquant sur le bouton, on me demande une première fois le nombre de ligne que je souhaite => je saisis le nombre; quand je clique à nouveau pour en ajouter même question, j'entre à nouveau un nombre mais rien ne s'ajoute.

Avez-vous une solution svp ?

Merci
 

job75

XLDnaute Barbatruc
Bonjour kay,

Oui ce n'était pas fini, avec cette macro du fichier (4) c'est mieux, les lignes 5:10 sont copiées :
VB:
Sub Bouton189_Cliquer()
Dim ncopie&, P As Range, h&, lig&, n&, o As OLEObject, c As Range
Application.CopyObjectsWithCells = True
With ActiveSheet
    If .Name = "Definitions" Or .Name = "fx" Or .Name = "Needs" Then Exit Sub
    ncopie = Int(Abs(Val(InputBox("Nombre de fois :", "Copier"))))
    Set P = .[5:10] 'plage à adapter
    h = P.Rows.Count
    lig = .Range("B" & .Rows.Count).End(xlUp).Row + 2 '2ème ligne vide sous le dernier tableau, à adapter
    Application.ScreenUpdating = False
    .DrawingObjects.Placement = 2
    For n = 1 To ncopie
        P.Copy P.Offset(lig - P.Row + h * (n - 1)) 'copie les cellules et les contrôles de formulaire
        For Each o In .OLEObjects 'boucle pour copier les contrôles ActiveX
            Set c = o.TopLeftCell
            If Not Intersect(P, c) Is Nothing Then
                With o.Duplicate 'duplication
                    .Left = o.Left
                    .Top = c.Offset(lig - P.Row + h * (n - 1)).Top + o.Top - c.Top
                End With
            End If
    Next o, n
End With
End Sub
A+
 

Pièces jointes

  • Formulaire JDD(4).xlsm
    71.2 KB · Affichages: 5

kay

XLDnaute Nouveau
Bonjour,

J'ai à nouveau besoin de votre aide svp.
Toujours sur le même sujet (je vais y arriver) :

J'aimerai que le bouton me copie colle toujours la même ligne mais avec les champs vides.
Je m'explique, actuellement quand j'entre des données dans les champs (que le bouton copie), et que je clique à la fin sur le fameux bouton afin d'ajouter de nouvelles lignes, les nouvelles lignes apparaissent avec les données entrées dans la première.

Comme ceci :

1565170937431.png


Est-il possible après avoir entrée des données dans les champs de cliquer sur le bouton et de copier les champs mais sans aucune données ?

Merci d'avance
Je vous mets le nouveau fichier en pièce jointe
 

Pièces jointes

  • Formulaire JDD.xlsm
    86.6 KB · Affichages: 7

job75

XLDnaute Barbatruc
Bonjour kay,

Vous deviez y arriver seule, il suffit d'ajouter une ligne pour effacer les données des nouvelles plages :
VB:
    For n = 1 To ncopie
        P.Copy P.Offset(lig - P.Row + h * (n - 1)) 'copie les cellules et les contrôles de formulaire
        P.Offset(lig - P.Row + h * (n - 1)) = "" 'efface les données
        For Each o In .OLEObjects 'boucle pour copier les contrôles ActiveX
PS : dans votre fichier je ne vois plus le bouton qui lance la macro...

A+
 

kay

XLDnaute Nouveau
Bonjour job75,

Merci pour votre réponse.
La ligne qui permet d'effacer les données efface seulement les textes des cellules et non le contenu des objets.
Voici le code en entier :

VB:
Sub Bouton189_Cliquer()
Dim ncopie&, P As Range, h&, lig&, n&, o As OLEObject, c As Range
Application.CopyObjectsWithCells = True
With ActiveSheet
    If .Name = "Definitions" Or .Name = "fx" Or .Name = "Needs" Then Exit Sub
    ncopie = Int(Abs(Val(InputBox("Nombre de fois :", "Copier"))))
    Set P = .[7:12]
    h = P.Rows.Count
    lig = .Range("B" & .Rows.Count).End(xlUp).Row + 6
    Application.ScreenUpdating = False
    .DrawingObjects.Placement = 2
    For n = 1 To ncopie
    P.Copy P.Offset(lig - P.Row + h * (n - 1))
    P.Offset(lig - P.Row + h * (n - 1)) = ""
        For Each o In .OLEObjects
            Set c = o.TopLeftCell
            If Not Intersect(P, c) Is Nothing Then
                With o.Duplicate
                    .Left = o.Left
                    .Top = c.Offset(lig - P.Row + h * (n - 1)).Top + o.Top - c.Top
                End With
            End If
    Next o, n
End With
End Sub
 
Dernière édition:

job75

XLDnaute Barbatruc
Oui bien sûr ce n'est pas les cellules qu'il faut vider mais les objets.

Alors voyez ce fichier (5) et cette nouvelle macro :
VB:
Sub Dupliquer()
Dim ncopie&, P As Range, h&, lig&, n&, o As Object, c As Range
With ActiveSheet
    If .Name = "Definitions" Or .Name = "fx" Or .Name = "Needs" Then Exit Sub
    ncopie = Int(Abs(Val(InputBox("Nombre de fois :", "Dupliquer"))))
    Set P = .[7:12] 'plage à adapter
    h = P.Rows.Count
    lig = .Range("B" & .Rows.Count).End(xlUp).Row + 5 '5ème ligne vide sous le dernier tableau, à adapter
    Application.ScreenUpdating = False
    .DrawingObjects.Placement = 3 'pour ne pas déplacer/copier les objets avec les cellules
    For n = 1 To ncopie
        P.Copy P.Offset(lig - P.Row + h * (n - 1)) 'copie uniquement les cellules
        For Each o In .DrawingObjects 'boucle pour copier tous les contrôles
            Set c = o.TopLeftCell
            If Not Intersect(P, c) Is Nothing Then
                With o.Duplicate 'duplication
                    .Left = o.Left
                    .Top = c.Offset(lig - P.Row + h * (n - 1)).Top + o.Top - c.Top
                    If TypeName(o) = "DropDown" Then .Text = "" 'zone de liste (contrôle de formulaire)
                    If TypeName(o) = "OLEObject" Then 'si contrôle ActiveX
                        If TypeName(o.Object) = "TextBox" Then .Object = ""
                        If TypeName(o.Object) = "CheckBox" Then .Object = False
                    End If
                End With
            End If
    Next o, n
End With
End Sub
Bonne nuit.
 

Pièces jointes

  • Formulaire JDD(5).xlsm
    92.4 KB · Affichages: 11

kay

XLDnaute Nouveau
Bonjour job75,

Que dire... vous êtes génial
Merci d'avoir pris le temps à chaque fois de me secourir et de répondre parfaitement à mes problématiques.

J'ai pu comprendre qu'il fallait procéder par type d'objet afin d'en effacer le contenu.

Je clos le sujet en vous remerciant à nouveau.

Très belle journée à tous
 

Discussions similaires

Réponses
10
Affichages
326

Statistiques des forums

Discussions
311 725
Messages
2 081 945
Membres
101 849
dernier inscrit
florentMIG