Dupliquer chaque ligne d'un tableau

Bonjour,

J'ai un tableau de plusieurs centaines de ligne à dupliquer (colonnes de A à U, 469 lignes).

J'aimerais créer une macro mais je ne sais pas répéter l'action.

Pouvez-vous m'aider SVP ?

J'ai une autre question, est-ce possible de faire exécuter la macro seulement si la cellule de la colonne V contient du texte ?

Bonjour,

Oui c'est possible je vais regarder. Est-ce un tableau "structuré" ou non ?

La cellule V est-elle vraiment vide ou contient des espaces ?

Bonjour,

Oui c'est un tableau structuré et je me suis trompée c'est la colonne U. Il y a des espaces.

J'aimerais dupliquer la ligne seulement si excel trouve une référence dans cette colonne.

Est-ce aussi possible de colorer la ligne copiée d'une couleur ?

Elle ressemble à ceci :

Bonjour,

Essayez la macro ci-après :

Si un ajustement est nécessaire c'est au début vous voyez range("A1"). Ainsi que worksheets(1). Mettez l'indice de votre feuille ou son nom entre guillemets. C'est une cellule du tableau (peu importe laquelle). Si la votre est différente, ajustez.

Sub DupliquerLignes()
  Application.ScreenUpdating = False

  Dim myTbl As ListObject
  Set myTbl = ThisWorkbook.Worksheets(1).Range("A1").ListObject

  Dim myRow As ListRow, i As Long
  i = 1

  Do While i <= myTbl.ListRows.Count
    Set myRow = myTbl.ListRows(i)
    If Replace(myRow.Range.Cells(1, 21).Value2, " ", vbNullString) <> vbNullString Then
      myTbl.ListRows.Add i + 1
      myRow.Range.Copy myTbl.ListRows(i + 1).Range
      i = i + 1
    End If
    i = i + 1
  Loop

  Application.ScreenUpdating = True
End Sub

Merci pour votre réponse. J'ai essayé le code mais il m'indique une erreur 91 et surligne une ligne en jaune :

Sub DupliquerLignes()
Application.ScreenUpdating = False

Dim myTbl As ListObject
Set myTbl = ThisWorkbook.Worksheets("Feuil1").Range("A2").ListObject

Dim myRow As ListRow, i As Long
i = 1

Do While i <= myTbl.ListRows.Count
Set myRow = myTbl.ListRows(i)
If Replace(myRow.Range.Cells(1, 21).Value2, " ", vbNullString) <> vbNullString Then
myTbl.ListRows.Add i + 1
myRow.Range.Copy myTbl.ListRows(i + 1).Range
i = i + 1
End If
i = i + 1
Loop

Application.ScreenUpdating = True
End Sub

Votre tableau n'est pas en A2 alors, ou ne contient aucune ligne…

Pouvez-vous joindre un fichier ? Êtes-vous sûre que vous avez bien un tableau structuré ?

Chez moi ca fonctionne sans problème, voyez l'exemple ci-joint.

En effet, cela marche avec votre tableau mais pas avec le miens.

Je ne peux pas vous l'envoyer avec toutes les données donc j'ai mis un extrait modifié sur une autre feuille du fichier ci-joint.

Comme anticipé, vous n'avez pas de tableau structuré. Prenez le temps de bien lire les questions, ca m'évitera de perdre le mien.

Un tableau structuré dans Excel, c'est ça : tableau structuré

Voici la macro dans votre cas, vous voyez que ça n'a rien à voir.

Sub DupliquerLignes2()
  Application.ScreenUpdating = False
  Dim i As Long: i = 2
  With ThisWorkbook.Worksheets("Feuil1")
    Do While .Cells(i, 1) <> vbNullString
      If Replace(.Cells(i, 21).Value2, " ", vbNullString) <> vbNullString Then
        Range(.Cells(i + 1, 1), .Cells(i + 1, 21)).Insert xlShiftDown
        Range(.Cells(i, 1), .Cells(i, 21)).Copy Range(.Cells(i + 1, 1), .Cells(i + 1, 21))
        i = i + 1
      End If
      i = i + 1
    Loop
  End With
  Application.ScreenUpdating = True
End Sub

La 1e ligne du tableau est référencée via i=2 tout en haut.

J'ai bien lu votre message mais à priori je ne savais pas que c'était un tableau structuré... J'en suis désolée.

Cela fonctionne et je vous remercie infiniment pour votre aide.

J'ai une dernière question, est ce qu'il y a la possibilité de colorer la ligne qui a été dupliquée ?

Si vous avez le temps, regardez le lien que je vous ai partagé, ils sont très utiles.

Oui bien entendu, pouvez-vous choisir une couleur sur ce site RGB Color Picker et me donner le code RGB correspondant à la couleur de coloriage que vous désirez ?

D'accord, merci.

Voici la couleur :

Bonjour à tous,

Comme il a été dit que c'était un tableau structuré (TS), j'ai transformé le tableau de la feuille "Feuil1" en TS. A priori cela n'a pas lieu d'être. Tant pis, je publie malgré tout.

Le petit plus est que même si on relance plusieurs fois la macro, les lignes déjà traitées sont "sautées". On fait cela par l'ajout d'une colonne "X" dans le TS. Mais tout cela est caduc puisque pas de TS... Comme je n'aime pas les tableaux multicolores, les paires de lignes dupliquées sont simplement entourées d'une bordure bleue.

Pour lancer la macro, cliquez sur le bouton "Hop !" de la cellule U1.

Le code est dans le module de code de la feuille "Feuil1".

Sub Duplication()
Dim dercol&, i&, ins&, j&
   Application.ScreenUpdating = False
   With Me.ListObjects(1)
      If .ListRows.Count = 0 Then Exit Sub
      If .Range(1, .ListColumns.Count) <> "X" Then
         .ListColumns.Add .ListColumns.Count + 1
         .Range(1, .ListColumns.Count) = "X"
      End If
      dercol = .ListColumns.Count
      .ListColumns(dercol).Range.HorizontalAlignment = xlLeft
      .ListColumns(dercol).Range.EntireColumn.AutoFit
      i = .ListRows.Count
      Do
         ins = 0
         If .ListRows(i).Range(dercol) <> "x" Then
            If .ListRows(i).Range(dercol - 1) <> "" Then
               .ListRows.Add i + 1
               .ListRows(i).Range.Copy .ListRows(i + 1).Range
               .ListRows(i).Range(dercol) = "x": .ListRows(i + 1).Range(dercol) = "x"
               For j = 7 To 10
                  .ListRows(i).Range.Resize(2).Borders(j).LineStyle = xlContinuous
                  .ListRows(i).Range.Resize(2).Borders(j).Weight = xlMedium
                  .ListRows(i).Range.Resize(2).Borders(j).Color = RGB(0, 0, 255)
               Next j
            End If
         End If
         i = i - 1: If i = 0 Then Exit Do
      Loop
   End With
End Sub

Re,

Même si les remarques de MaFraise sont très pertinentes (notamment sur le fait d'éviter les multiples duplicatas), je vous remet ci-après la macro avec la coloration des lignes comme demandé.

J'ai simplement ajouté la ligne ci-dessous. (voyez que la couleur sera un poil différente car le canal alpha (transparence) que vous avez modifié n'est pas pris en charge), mais bon vous voyez comment modifier par vous-même dans la fonction "RGB".

Range(.Cells(i + 1, 1), .Cells(i + 1, 21)).Interior.Color = RGB(0, 176, 240)

Macro complète :

Sub DupliquerLignes2()
  Application.ScreenUpdating = False
  Dim i As Long: i = 2
  With ThisWorkbook.Worksheets("Feuil1")
    Do While .Cells(i, 1) <> vbNullString
      If Replace(.Cells(i, 21).Value2, " ", vbNullString) <> vbNullString Then
        Range(.Cells(i + 1, 1), .Cells(i + 1, 21)).Insert xlShiftDown
        Range(.Cells(i, 1), .Cells(i, 21)).Copy Range(.Cells(i + 1, 1), .Cells(i + 1, 21))
        Range(.Cells(i + 1, 1), .Cells(i + 1, 21)).Interior.Color = RGB(0, 176, 240)
        i = i + 1
      End If
      i = i + 1
    Loop
  End With
  Application.ScreenUpdating = True
End Sub

Pas de problème pour la couleur, cela fonctionne parfaitement =) Vous m'avez fait gagner un temps précieux.

Merci beaucoup !

Bien, merci pour votre retour.

Re,

Pour le fun, la même version mais pour une plage ordinaire et non un TS. La méthode est très rapide.

Cette fois-ci, les couleurs alternent et ne concernent que la police - c'est plus lisible selon moi.

Mais comme je suis transparent...

Joli travail MaFraise, très efficace. J'aime bien la mise en couleur du texte.

Bonjour saboh12617 ,

C'est le formatage qui requiert le plus de temps à mettre au point (pas difficile mais long à mettre au point pour un joli résultat - selon ma perception). Mais c'est vrai que depuis quelque temps, je suis enclin à diminuer le nombre de couleurs et à utiliser des couleurs claires.