Duplication et Insertion Word

[Arcanum]

Bonjour le Forum !

J'explique mon problème : J'ai un fichier excel contenant des données (deux colonnes utiles : Nom/Prénom (Colonne D) et texte (Colonne C)). Je dois insérer pour une ligne, le texte à un endroit sur une feuille word, et le nom/prénom à un autre endroit. Pour ça, j'ai utilisé des signets, ça fonctionne très bien.

Le problème est que je dois dupliquer la première page avec le même modèle, autant de fois qu'il y a de ligne. Je n'ai donc aucun problème pour l'insertion, je suis surtout bloqué pour la duplication de ma page word.

Je précise également que j’exécute tout ça depuis un clique sur un bouton sur le fichier excel. Voici mon code :

Function GetFilesMaximes() As String

    Dim f As Object
    
    Set f = Application.FileDialog(msoFileDialogFilePicker)
    f.Title = "Sélectionner le fichier des Maximes"
    f.AllowMultiSelect = False
    f.InitialFileName = ActiveWorkbook.Path
    
    f.Show

    If f.SelectedItems.Count > 0 Then
        GetFilesMaximes = f.SelectedItems(1)
    End If
    
    Set f = Nothing
    
End Function

Function GetFilesAgent() As String

    Dim f As Object
    
    Set f = Application.FileDialog(msoFileDialogFilePicker)
    f.Title = "Sélectionner le fichier des Agents"
    f.AllowMultiSelect = False
    f.InitialFileName = ActiveWorkbook.Path
    
    f.Show
    
    If f.SelectedItems.Count > 0 Then
        GetFilesAgent = f.SelectedItems(1)
    End If
    
    Set f = Nothing
    
End Function

Function GetFilesChevalet() As String

    Dim f As Object
    
    Set f = Application.FileDialog(msoFileDialogFilePicker)
    f.Title = "Sélectionner le fichier des Chevalets"
    f.AllowMultiSelect = False
    f.InitialFileName = ActiveWorkbook.Path
    
    f.Show
    
    If f.SelectedItems.Count > 0 Then
        GetFilesChevalet = f.SelectedItems(1)
    End If
    
    Set f = Nothing
    
End Function

Sub createChevalet()
'Procédure générant un fichier word contenant les chevalets

    Dim fichierAgent As String
    Dim fichierMaximes As String
    Dim WorkBookAgent As Workbook
    Dim WorkBookMaximes As Workbook
    Dim WorkBookPrincipal As Workbook
    Dim WordApp As Word.Application
    Dim WordDoc As Word.Document
    Dim dernLigneAgent As Integer
    Dim dernLigneMaxime As Integer
    Dim i As Integer
    Dim j As Integer
    Dim ligneRandom As Integer
    Dim data As New Collection
    
    Set WorkBookPrincipal = ActiveWorkbook
    
    'Vide les anciennes données s'il y en a
    WorkBookPrincipal.Sheets("Récupération").Range("A1:C65536").ClearContents
    
    'Récuperation des noms de fichiers où se trouvent les données
    fichierAgent = GetFilesAgent
    fichierMaximes = GetFilesMaximes
    fichierChevalet = GetFilesChevalet
    
    Set WorkBookAgent = Workbooks.Open(Filename:=fichierAgent)  'Ouverture du fichier Agent
    
    'Récupère la dernière ligne remplit du fichier agent
    '"Agents" à changer ainsi que la plage selon où se trouve le nom et prénom
    dernLigneAgent = WorkBookAgent.Sheets("Agents").Range("A65536").End(xlUp).Row
    WorkBookAgent.Sheets("Agents").Range("B2:C" & dernLigneAgent).Copy WorkBookPrincipal.Sheets("Récupération").Range("A1")
    WorkBookAgent.Close savechanges:=False 'ferme le fichier
    
    Randomize
    
    Set WorkBookMaximes = Workbooks.Open(Filename:=fichierMaximes)  'Ouverture du fichier Maximes

    'Récupère la dernière ligne remplit du fichier Maximes
    dernLigneMaxime = WorkBookMaximes.Sheets("FC").Range("A65536").End(xlUp).Row
    
    ligneRandom = ((dernLigneMaxime * Rnd - 2) + 2)
    For i = 1 To dernLigneAgent - 1
        For j = 1 To data.Count
            If ligneRandom = data(j) Then
                ligneRandom = ((dernLigneMaxime * Rnd - 2) + 2)
                j = 1
            End If
        Next
        data.Add ligneRandom
        WorkBookMaximes.Sheets("FC").Range("A" & ligneRandom).Copy WorkBookPrincipal.Sheets("Récupération").Range("C" & i)
        ligneRandom = ((dernLigneMaxime * Rnd - 2) + 2)
    Next
    
    WorkBookMaximes.Close savechanges:=False 'ferme le fichier
    
    Set WordApp = CreateObject("word.application")
    Set WordDoc = WordApp.Documents.Open(Filename:=fichierChevalet) 'Ouverture du fichier des chevalets
    WordDoc.Bookmarks("nom").Range.Text = WorkBookPrincipal.Sheets("Récupération").Range("D1").Value
    WordDoc.Bookmarks("maximes").Range.Text = WorkBookPrincipal.Sheets("Récupération").Range("C1")
    
    WordApp.Quit
    Set WordApp = Nothing
    
End Sub

Merci de votre aide, tout en sachant que je ne sais pas si c'est possible, j'attend donc vos réponses

 

[Modeste]

Re : Duplication et Insertion Word

Bonjour Arcanum,

Pas regardé le code, mais en fonction de tes explications, ce que tu cherches à faire ressemble furieusement à du publipostage, non

 

[Arcanum]

Re : Duplication et Insertion Word

Mon tuteur de stage m'a effectivement signalé que s'en été. Je pense donc pouvoir m'en sortir . J'essaye d'être le plus autonome possible donc je posais la question de savoir si c'était possible avant de demander. Merci de ta réponse et bonne journée .