XL 2019 Copie de cellules avec ajout de lignes par référence

[Bormio2]

Bonjour,

Compte tenu de mes connaissances Excel (limitées), je m'interroge sur la faisabilité de l'opération suivante.

J'ai en Feuil1 une liste de références en cellule A1, A2, A3.... (format de cellule texte)

En Feuil2, j'ai une liste d'indicateurs en A1, A2, A3... (format de cellule standard)

Je souhaiterais savoir s'il est possible "simplement" de recopier le contenu de toutes les cellules non vides de la Feuil2 (collone A) dans la Feuil1 (collone B), de manière à ce que cette copie duplique le contenu de la cellule A1 (Feuill1) autant de fois qu'il y a de références en Feuil2.

Je joins un fichier d'exemple pour éclaircir ma demande avec le résultat attendu en Feuil3 sachant que cet exemple est bien sûr limité en volume de données.

Merci à vous pour vos lumières et éventuelles solutions,

Cordialement,

 

[Phil69970]

Bonjour @Bormio2, le forum

Je te propose ce fichier

@Phil69970

 

[Bormio2]

Bonjour Phil,

Merci pour cette réponse et pour le fichier joint.

Malheureusement, "impossible d’exécuter la macro, il est possible qu'elle ne soit pas dans le classeur ou que les macros soient désactivées".

Les macros sont pourtant toutes activées avec "Accès approuvé au modèle d'objet du projet VBA"...

Cordialement,

 

[Phil69970]

Bonjour @Bormio2, le forum

J'ai l'impression que cela concerne ton niveau de sécurité des macros qui bloque l'exécution des macros.

La seule choses que je peux te proposer c'est que tu copies le code dans ton fichier
*Attention tu dois enregistrer ton fichier en .XLSM

voici le code à copier dans ton fichier du post #1 :

Sub MAJ()
Application.ScreenUpdating = False
Dim Derlig&, DL&
Dim cpt&

With Worksheets("Feuil1")
    Derlig = .Range("A" & Rows.Count).End(xlUp).Row
    DL = Worksheets("Feuil2").Range("A" & Rows.Count).End(xlUp).Row
    .Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    .Columns("B:B").NumberFormat = "@"
    .[B1] = [A1]
    .[C1] = Worksheets("Feuil2").[A1]
    cpt = 2
    For i = 2 To Derlig
        For j = 2 To DL
            .Range("B" & cpt) = .Range("A" & i).Value
            .Range("C" & cpt) = Worksheets("Feuil2").Range("A" & j).Value
            cpt = cpt + 1
        Next j
    Next i
    .Columns("A:A").Delete Shift:=xlToLeft
End With
End Sub

et voici le dit fichier une nouvelle fois.....

*Edit
J'ai essayé de télécharger mon fichier il fonctione tres bien
As tu accepté les messages lors de l'ouverture du fichier

@Phil69970

 

[Bormio2]

rebonjour @Phil69970,

Après recopie du code dans le fichier, cela fonctionne très bien, c'est parfait !!

Merci pour la solution et pour le gain de temps que cela va m'apporter.

Bonne journée.

@Bormio2