XL 2016 Dupliquer x fois le contenu de cellules en fonction de la valeur x contenu dans une autre

thomasdu43 · 21 Septembre 2020

Bonjour,
J'ai créé un rapport sous excel et souhaite pouvoir dupliquer son contenu tout en conservant sa forme, et ce, autant de fois que la valeur contenue dans une de ses cellules.
Dans l'exemple, la cellule de référence pour dupliquer le rapport est en C13.
En fonction de la valeur en C13, je souhaite que le rapport se multiplie autant de fois soit à partir de la ligne 48, soit à partir de la colonne I, peu importe.
Je vous remercie pour votre aide.
Cordialement.

job75 · 21 Septembre 2020

Bonjour thomasdu43,

Cellule C13 ? je suppose qu'il s'agit de H13...

Tel qu'est constitué le rapport il vaut mieux dupliquer horizontalement :

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [H13]) Is Nothing Then Exit Sub
Dim n, P As Range, ncol%, i%
n = Val([H13])
Set P = Columns("A:I") 'à adapter
ncol = P.Columns.Count
Application.ScreenUpdating = False
Columns("J").Resize(, Columns.Count - 9).Delete 'RAZ
For i = 1 To n - 1
    P.Copy P.Offset(, i * ncol)
Next
End Sub

La macro se déclenche quand H13 est modifiée.

A+

sousou · 21 Septembre 2020

Bonjour
Quelque chose comme ceci
Sub deb()
der = Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1).End(xlUp).Row
For n = 1 To Range("c13")
Range(Cells(1, 1), Cells(der + 1, 10)).Copy Cells(1, (10 * n) + 1)
Next
End Sub

job75 · 21 Septembre 2020

Bonjour sousou,

En copie horizontale il faut copier les largeurs des colonnes...

En copie verticale il faut copier les hauteurs des lignes...

A+

thomasdu43 · 21 Septembre 2020

job75 à dit:
Bonjour thomasdu43,

Cellule C13 ? je suppose qu'il s'agit de H13...

Tel qu'est constitué le rapport il vaut mieux dupliquer horizontalement :

VB:

Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, [H13]) Is Nothing Then Exit Sub Dim n, P As Range, ncol%, i% n = Val([H13]) Set P = Columns("A:I") 'à adapter ncol = P.Columns.Count Application.ScreenUpdating = False Columns("J").Resize(, Columns.Count - 9).Delete 'RAZ For i = 1 To n - 1 P.Copy P.Offset(, i * ncol) Next End Sub

La macro se déclenche quand H13 est modifiée.

A+

Bonjour Job75, Merci de votre aide, ça répond totalement à mes attentes.
Bonne soirée

ntb · 19 Avril 2021

job75 à dit:
Bonjour thomasdu43,

Cellule C13 ? je suppose qu'il s'agit de H13...

Tel qu'est constitué le rapport il vaut mieux dupliquer horizontalement :

VB:

Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, [H13]) Is Nothing Then Exit Sub Dim n, P As Range, ncol%, i% n = Val([H13]) Set P = Columns("A:I") 'à adapter ncol = P.Columns.Count Application.ScreenUpdating = False Columns("J").Resize(, Columns.Count - 9).Delete 'RAZ For i = 1 To n - 1 P.Copy P.Offset(, i * ncol) Next End Sub

La macro se déclenche quand H13 est modifiée.

A+

Bonjour job,

Ta macro est superbe mais comment faut-il faire pour que cela soit non pas copié à côté mais en dessous?

Merci pour ton aide

job75 · 19 Avril 2021

Bonjour ntb,

Bah il suffit de remplacer les colonnes par des lignes, fichier (2) :

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [H13]) Is Nothing Then Exit Sub
Dim n, P As Range, nlig&, i&
n = Val([H13])
Set P = Rows("1:32") 'à adapter
nlig = P.Rows.Count
Application.ScreenUpdating = False
Rows(nlig + 1).Resize(Rows.Count - nlig).Delete 'RAZ
For i = 1 To n - 1
    P.Copy P.Offset(i * nlig)
Next
End Sub

A+

ntb · 19 Avril 2021

job75 à dit:

Bonjour ntb,

Bah il suffit de remplacer les colonnes par des lignes, fichier (2) :

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [H13]) Is Nothing Then Exit Sub
Dim n, P As Range, nlig&, i&
n = Val([H13])
Set P = Rows("1:32") 'à adapter
nlig = P.Rows.Count
Application.ScreenUpdating = False
Rows(nlig + 1).Resize(Rows.Count - nlig).Delete 'RAZ
For i = 1 To n - 1
    P.Copy P.Offset(i * nlig)
Next
End Sub

A+

Ah oui c'est super ça marche parfaitement

Merci beaucoup et à +

ntb · 19 Avril 2021

job75 à dit:

Bonjour ntb,

Bah il suffit de remplacer les colonnes par des lignes, fichier (2) :

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [H13]) Is Nothing Then Exit Sub
Dim n, P As Range, nlig&, i&
n = Val([H13])
Set P = Rows("1:32") 'à adapter
nlig = P.Rows.Count
Application.ScreenUpdating = False
Rows(nlig + 1).Resize(Rows.Count - nlig).Delete 'RAZ
For i = 1 To n - 1
    P.Copy P.Offset(i * nlig)
Next
End Sub

A+

Re,

Dernière petite question, comment faut-il faire pour par exemple coller non pas la ligne directement après mais par exemple 5 lignes plus loin?

Merci d'avance

job75 · 19 Avril 2021

VB:

For i = 1 To n - 1
    P.Copy P.Offset(i * (nlig + 5))
Next

ntb · 19 Avril 2021

job75 à dit:
VB:

For i = 1 To n - 1 P.Copy P.Offset(i * (nlig + 5)) Next

Super merci beaucoup

XL 2016 Dupliquer x fois le contenu de cellules en fonction de la valeur x contenu dans une autre

thomasdu43

XLDnaute Occasionnel

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

sousou

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

thomasdu43

XLDnaute Occasionnel

ntb

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

ntb

XLDnaute Nouveau

ntb

XLDnaute Nouveau

job75

XLDnaute Barbatruc

ntb

XLDnaute Nouveau

Discussions similaires