Microsoft 365 Dupliquer automatiquement lignes

[thr92]

Bonjour,

J'ai cet immense tableau à travailler et je cherche une solution moins chronophage pour y arriver. Il faut que je duplique chaque lignes autant que de nombre à partir de la colonne AA.

Exemple : dupliquer la ligne A2:Y2 7 fois et faire apparaitre successivement en colonne Z les numéros de semaines
1ere duplication : ligne A2:Y2 43, 2ème ligne A2:Y2 44 etc etc...

Si quelqu'un a une solution à ça, je suis preneuse !

Merci par avance et bonne semaine

P.S : j'ai dû supprimer des lignes pour pouvoir vous joindre le fichier mais j'ai à peu près 3300 lignes à traiter

 

[fanch55]

Bonjour,
Dans le classeur, la colonne Z n'est pas renseignée ?

 

[st007]

Avec power query ?
edit : oops, fichier trop volumineux du coup et explications
j'ai ajouté A:H au premier tableau,puis power query (obtenir des données depuis un tableau)
Selectionné A:Z, Dépivoter les autres colonnes
supprimé la colonne attribut, puis renommé la colonne valeurs en semaine

 

[chris]

Bonjour à tous

C'est typiquement ce qu'on fait en quelques clics avec PowerQuery intégré à ta version Excel

Il manque cependant des infos : d'où vient le tableau ? D'un copier coller manifestement et ensuite quel est la finalité pour être sûr d'adopter la bonne approche...

EDIT : st007 : tu as posté l'original

 

[fanch55]

Salut à tous,
Je suis pommé là, de quoi parle-t-on ?

 

[sylvanu]

Bonjour Thr, St, Fanch, Chris,
Un essai en PJ.
Mais le feuil1 contient tellement de mise en forme et MFC que l'utiliser pour dupliquer les lgnes est vraiment trop long.
Donc en PJ je crée une nouvelle feuille appelée Dupliqué, mais malgré ça pour 2093 lignes, sur mon PC cela génère 16600 lignes en 138s soit plus de 2min. Avec :

Sub Duplique()
    Dim T0, F, Lig, L, N, Nb
    T0 = Timer
    Cells.ClearContents
    Application.ScreenUpdating = False
    Set F = Sheets("Feuil1")            ' A modifier suivant nom feuille BDD
    ActiveWorkbook.Save
    Lig = 2
    DL = F.Range("A65500").End(xlUp).Row
    Range("A1:Y1") = F.Range("A1:Y1").Value ' Copie des titres
    For L = 2 To DL
        Application.StatusBar = "Progression : " & L & " sur " & DL
        N = Application.CountIf(F.Range(F.Cells(L, "AA"), F.Cells(L, "CA")), ">0")
        Range("A" & Lig & ":Y" & Lig + N - 1) = F.Range("A" & L & ":Y" & L).Value ' Copier Coller valeurs
        For Nb = 1 To N ' Ajout des N°
            Cells(Lig + Nb - 1, "Z") = F.Cells(L, 26 + Nb)
        Next Nb
        Lig = Lig + N
    Next L
    Hmin
    Application.StatusBar = ""
    Application.ScreenUpdating = True
    ActiveWorkbook.Save
    MsgBox "Temps d'éxécution : " & Int(Timer - T0) & "s"
End Sub

 

[merinos]

Bonjour @thr92 , et a tous....
Je n'ai gardé que 36 lignes, mais cela fonctionne avec plus...

Effectivement il suffit de "de-pivoter" les colonnes.

 

[mapomme]

Bonjour à tous,

Pour le fun, une autre méthode très rapide. Le code est dans module1.
Cliquez sur le bouton Dupliquer. Environ 1,6 seconde pour 3500 lignes de données source.

Sub Dupliquer()
Dim t, der&, i&, j&, n&, k&, debut
   debut = Timer
   With Sheets("Feuil1")      'lecture données source dans tableau t
      If .FilterMode Then .ShowAllData
      der = .Cells(Rows.Count, "a").End(xlUp).Row
      t = .Range("a1:bx1").Resize(der)
   End With
   ReDim res(1 To 48 * UBound(t), 1 To 26)   'tableau résultat
   'recopie des en-têtes
   n = 1: For j = 1 To 26: res(n, j) = t(n, j): Next
   'duplications des autres lignes
   For i = 2 To UBound(t)
      For j = 27 To 74
         t(i, j) = Int(Val(Trim(t(i, j))))
         If t(i, j) > 0 Then
            n = n + 1: res(n, 26) = t(i, j)
            For k = 1 To 25: res(n, k) = t(i, k): Next
         End If
      Next j
   Next i
   'résultat sur feuille "Duplication"
   With Sheets("duplication")
      .Columns("a:z").ClearContents
      .Range("a1").Resize(n, UBound(res, 2)) = res
      .Select
   End With
   MsgBox "Résultat : " & Format(n - 1, "#,##0") & " lignes de données" & vbLf & vbLf & _
         "Durée d'exécution : " & Format(Timer - debut, "0.0\ sec.")
End Sub

 

[st007]

ouahhh, 3 messages, 3 requêtes similaires