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

N

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 =...
Trier par date Trier par votes

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
Vote positif 0 Vote négatif
Solution

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
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

N
  • Résolu(e)
XL 2016 créer un tableau qui contient tous les distances entre les stations de bus
Réponses
4
Affichages
510
nasri badreddine
N
M
  • Question
XL 2019 Transposer des données d'une feuille vers une autre sous forme de synthèse
Réponses
8
Affichages
262
mromain
S
  • Résolu(e)
Microsoft 365 Ecrasement d'une ligne si déjà existante
Réponses
2
Affichages
158
sebastien176
S
F
  • Résolu(e)
Microsoft 365 copier coller des colonnes en fonction de la valeur d'une cellule
Réponses
8
Affichages
626
loloboc
L
J
  • Question
XL 2021 Résolu - Extractions de valeurs Ligne pour créer des lignes isolées / Macro Séparer Valeurs
Réponses
14
Affichages
376
JM04082023!
J
N
  • Résolu(e)
Microsoft 365 Rechercher la dernière cellule saisie dans un TS et ajouter l'heure système
18 19 20
Réponses
291
Affichages
67 K
NONO14
N
M
  • Question
XL 2010 Comment alimenter automatiquement des cellules à partir d'une ligne sélectionnée dans un tableau?
Réponses
13
Affichages
960
ManuXZ
M
C
  • Question
XL 2021 Problème de remplissage d'une colonne conditionné à d'autres valeurs
Réponses
2
Affichages
372
CathyLD
C
F
  • Question
XL 2016 Nom de la ligne avec la Valeur max
Réponses
4
Affichages
479
fanfanus
F
P
  • Résolu(e)
XL 2021 Besoin d'aide pour copier/coller données de plusieurs classeurs
2
Réponses
20
Affichages
679
Pac41240
P
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…