Résolu 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
 
Ce fil a été résolu! Aller à la solution…

Fichiers joints

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.
 
Ce message a été identifié comme étant une solution!

Fichiers joints

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+
 

Fichiers joints

Amilo

XLDnaute Accro
Bonjour nanoux64, job75, mapomme, le forum,
Voici une proposition avec Power Query (dans le 2ème onglet),
Cordialement
 

Fichiers joints

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas