Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2019 Comment recopier une ligne autant de fois que la valeur d'une cellule

nanoux64

XLDnaute Nouveau
Bonsoir à tous(tes),

Je suis nouvelle dans le forum et j'aurai besoin d'aide pour du codage VBA. Mon problème est relativement simple, mais je ne sais juste pas coder
Dans mon jeu de données, chaque ligne comporte un effectif dans les colonnes : "Nbre distance contact < 25 m (colonne N), Nbre distance contact 25-100 m (colonne O) et Nbre distance contact >100 m (colonne P). Je souhaiterai dans une nouvelle feuille que chaque ligne soit recopiée autant de fois que l'effectif donné pour chacune des 3 colonnes citées dessus, et ceci pour toutes les lignes. L'objectif étant d'avoir l'effectif non plus en donnée dans une cellule mais en nombre de ligne (j'espère être claire)

Par exemple:
Ligne n°1 [...] Nbre distance contact >100 m = 3
-->
Ligne n°1 recopiée 3 fois


Pour avoir à la fin 1 ligne = 1 obs/contact avec, au lieu des 3 colonnes "Nbre distance contact", plus qu'une seule colonne "Distance" comportant la distance à laquelle le contact a été fait, c'est à dire, dire pour chaque ligne/observation à quelle colonne elle appartenait

Je souhaite analyser ces données sur un logiciel qui demande ce format là... et avec autant de ligne, la manière "conventionnelle" est très gourmande en temps et en patience, avec un risque trop élevé d'erreur

Vous trouverez en PJ un extrait de mon jdd.xlsx, l'original comporte au total 1362 lignes. La 2nd feuille précise le rendu désiré

Je vous remercie pour vos réponses
 

Pièces jointes

  • jdd.xlsx
    19 KB · Affichages: 24
Solution
Bonsoir nanoux64, bienvenue sur XLD,

Voyez le fichier joint et cette macro dans le code de la feuille "Résultat" (clic droit sur l'onglet et Visualiser le code) :
VB:
Private Sub Worksheet_Activate()
Dim tablo, i&, resu(), j&, n&, k%
tablo = Sheets("Feuil1").[A1].CurrentRegion.Resize(, 19)
ReDim resu(1 To Rows.Count, 1 To 17)
For i = 2 To UBound(tablo)
    For j = 1 To Val(tablo(i, 14))
        n = n + 1
        For k = 1 To 17
            resu(n, k) = tablo(i, IIf(k > 14, k + 2, k))
        Next k
        resu(n, 14) = "<25m"
    Next j
    For j = 1 To Val(tablo(i, 15))
        n = n + 1
        For k = 1 To 17
            resu(n, k) = tablo(i, IIf(k > 14, k + 2, k))
        Next k
        resu(n, 14) = "25-100m"
    Next j
    For j =...

job75

XLDnaute Barbatruc
Bonsoir nanoux64, bienvenue sur XLD,

Voyez le fichier joint et cette macro dans le code de la feuille "Résultat" (clic droit sur l'onglet et Visualiser le code) :
VB:
Private Sub Worksheet_Activate()
Dim tablo, i&, resu(), j&, n&, k%
tablo = Sheets("Feuil1").[A1].CurrentRegion.Resize(, 19)
ReDim resu(1 To Rows.Count, 1 To 17)
For i = 2 To UBound(tablo)
    For j = 1 To Val(tablo(i, 14))
        n = n + 1
        For k = 1 To 17
            resu(n, k) = tablo(i, IIf(k > 14, k + 2, k))
        Next k
        resu(n, 14) = "<25m"
    Next j
    For j = 1 To Val(tablo(i, 15))
        n = n + 1
        For k = 1 To 17
            resu(n, k) = tablo(i, IIf(k > 14, k + 2, k))
        Next k
        resu(n, 14) = "25-100m"
    Next j
    For j = 1 To Val(tablo(i, 16))
        n = n + 1
        For k = 1 To 17
            resu(n, k) = tablo(i, IIf(k > 14, k + 2, k))
        Next k
        resu(n, 14) = ">100m"
Next j, i
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination, à adapter
    If n Then .Resize(n, 17) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 17).ClearContents 'RAZ en dessous
End With
End Sub
Elle se déclenche quand on active la feuille.

Son exécution est rapide car elle utilise des tableaux VBA.

Bonne nuit.
 

Pièces jointes

  • jdd(1).xlsm
    28.2 KB · Affichages: 13

job75

XLDnaute Barbatruc
Bonsoir nanoux64, mapomme, le forum,

Un code plus "ramassé" grâce à la boucle col dans ce fichier (2) :
VB:
Private Sub Worksheet_Activate()
Dim tablo, resu(), a, i&, col As Byte, j&, n&, k%
tablo = Sheets("Feuil1").[A1].CurrentRegion.Resize(, 19)
ReDim resu(1 To Rows.Count, 1 To 17)
a = Array("<25m", "25-100m", ">100m")
For i = 2 To UBound(tablo)
    For col = 0 To 2
        For j = 1 To Val(tablo(i, 14 + col))
            n = n + 1
            For k = 1 To 17
                resu(n, k) = tablo(i, IIf(k > 14, k + 2, k))
            Next k
            resu(n, 14) = a(col)
Next j, col, i
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination, à adapter
    If n Then .Resize(n, 17) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 17).ClearContents 'RAZ en dessous
End With
End Sub
A+
 

Pièces jointes

  • jdd(2).xlsm
    28.3 KB · Affichages: 7

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…