Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

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


Sujet :

Macros et VBA Excel

  1. #1
    Candidat au Club
    Générer fichier à partir d'une liste
    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.


    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

  2. #2
    Expert éminent sénior
    Citation Envoyé par elbrens Voir le message

    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 :Sélectionner tout -Visualiser dans une fenêtre à part
    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 :Sélectionner tout -Visualiser dans une fenêtre à part
    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
    Eric KERGRESSE
    https://sites.google.com/site/erickergresseeirl/
    Lorsque vous avez la réponse à votre question, n'oubliez pas de cliquer sur et si celle-ci est pertinente pensez à voter

  3. #3
    Candidat au Club
    Bonjour,

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

    Belle journée

###raw>template_hook.ano_emploi###