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
Génial !Vous ne connaissez pas les boucles For/Next ?
La macro adaptée dans ce fichier (3) :
A+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
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
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
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
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
Tout à fait car les objets n'ont pas les mêmes propriétés et certains, comme ici les TextBoxes de formulaire, ne doivent pas être modifiés.J'ai pu comprendre qu'il fallait procéder par type d'objet afin d'en effacer le contenu.