Générer fichier à partir d'une liste

2 pièce(s) jointe(s)

Bonjour,

je souhaite générer diffèrent fichier a partir d'une liste

j'ai un fichier type dans lequel la macro doit reprendre diffèrent éléments de la liste et l'insérer a des emplacements spécifiques pour créer une fiche personnalisé pour chaque ligne de la liste.
Pièce jointe 584576

j'ai réussi a créer une macro qui réalise exactement ce que je souhaite mais, elle ne reprend que la 1er ligne et ne boucle pas sur le reste des lignes
Merci pour votre aide

Citation:

Envoyé par elbrens

Bonjour,

Votre onglet 1 est remplacé par l'onglet Modèle. Dans votre onglet Liste, ajout à la fin de la colonne Lien.

Dans un module standard :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
 
 
Sub Generer_fiche_client()
 
Dim ShModele As Worksheet, ShListe As Worksheet, shCommande As Worksheet
Dim I As Long, DerniereLigne As Long
Dim AireListe As Range
Dim NomDeLOnglet As String
 
    On Error GoTo Fin
 
    Application.ScreenUpdating = False
 
    SuppressionOngletsCommandes
 
    Set ShModele = Sheets("Modèle")
    Set ShListe = Sheets("Liste")
 
    With ShListe
         DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
         Set AireListe = .Range(.Cells(2, 1), .Cells(DerniereLigne, 1))
    End With
 
    For I = 1 To AireListe.Count
        ShModele.Copy after:=Sheets(Sheets.Count)
        Set shCommande = Sheets(Sheets.Count)
        With AireListe(I)
            NomDeLOnglet = .Offset(0, 7) & " " & "Cde " & .Offset(0, 1)
            shCommande.Name = NomDeLOnglet
            CopierColler AireListe(I), shCommande
            ShListe.Hyperlinks.Add Anchor:=AireListe(I).Offset(0, 8), Address:="", SubAddress:="'" & NomDeLOnglet & "'!A1", TextToDisplay:=AireListe(I).Offset(0, 7).Value
        End With
        Set shCommande = Nothing
 
    Next I
 
    ShListe.Activate
    Application.ScreenUpdating = True
 
    MsgBox "Fin de traitement !", vbInformation
 
    GoTo Fin
 
 
Fin:
 
    Application.ScreenUpdating = True
 
    Set AireListe = Nothing
    Set ShModele = Nothing
    Set ShListe = Nothing
 
 
End Sub
 
Sub CopierColler(ByVal CelluleEnCours As Range, ByVal ShCommande2 As Worksheet)
 
    With CelluleEnCours
         .Copy Destination:=ShCommande2.Range("J11")              ' Numéro de colis
         .Offset(0, 1).Copy Destination:=ShCommande2.Range("G11") ' Numéro de commande
         .Offset(0, 2).Copy Destination:=ShCommande2.Range("C13") ' Nom prénom
         .Offset(0, 7).Copy Destination:=ShCommande2.Range("J13") ' Emplacement
    End With
 
End Sub
 
Sub SuppressionOngletsCommandes()
 
Dim I As Long
 
    Application.DisplayAlerts = False
    For I = Sheets.Count To 1 Step -1
        Select Case Sheets(I).Name
               Case "Modèle", "Liste"
 
               Case Else
                    Sheets(I).Delete
        End Select
    Next I
    Application.DisplayAlerts = False
 
    With Sheets("Liste")
 
         I = .Cells(.Rows.Count, 1).End(xlUp).Row
         If I > 1 Then .Range(.Cells(2, 9), .Cells(I, 9)).Clear
 
    End With
 
End Sub

Dans le module de l'onglet Modèle :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
 
Option Explicit
 
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
   If Target.Count > 1 Then Exit Sub
 
   If Not Intersect(Target, Range("C13")) Is Nothing Then
      With Target
           .Font.Size = 36
           .Font.Name = "Calibri"
           .Font.Bold = True
            .Borders(xlEdgeLeft).Weight = xlMedium
            .Borders(xlEdgeBottom).Weight = xlMedium
      End With
   End If
 
   If Not Intersect(Target, Range("G11")) Is Nothing Then
      With Target
           .Font.Size = 12
           .Font.Name = "Calibri"
           .Font.Bold = True
           .Borders(xlEdgeRight).Weight = xlMedium
      End With
   End If
 
   If Not Intersect(Target, Range("J11")) Is Nothing Then
      With Target
           .Font.Size = 12
           .Font.Name = "Calibri"
           .Font.Bold = True
           .Borders(xlEdgeRight).Weight = xlMedium
      End With
   End If
 
   If Not Intersect(Target, Range("J13")) Is Nothing Then
      With Target
           .Font.Size = 36
           .Font.Name = "Calibri"
           .Font.Bold = True
           .Borders(xlEdgeRight).Weight = xlMedium
           .Borders(xlEdgeBottom).Weight = xlMedium
      End With
   End If
 
 
End Sub

Bonjour,

Parfait, c'est exactement ce que je voulais ;)
Merci beaucoup pour votre aide

Belle journée