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
|
Option Explicit
Sub CreerLesDocuments()
'Dim WApp As Word.Application, DocWord As Word.Document
Dim WApp As Object, DocWord As Object ' En late binding
Dim LigneEncours As Long, DerniereLigne As Long
Dim AireDocuments As Range
With Sheets("Feuil1")
DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
Set AireDocuments = .Range(.Cells(2, 1), .Cells(DerniereLigne, 1))
End With
Set WApp = CreateObject("word.application")
With WApp
.Visible = True
For LigneEncours = 1 To AireDocuments.Count
With AireDocuments(LigneEncours)
Set DocWord = WApp.Documents.Add(Template:=ThisWorkbook.Path & "\Modèle courrier.dotx")
MajSignets DocWord, AireDocuments(LigneEncours)
DocWord.SaveAs Filename:=ThisWorkbook.Path & "\" & AireDocuments(LigneEncours).Value & ".docx", FileFormat:=12
DocWord.Close
End With
Next LigneEncours
End With
WApp.Quit
MsgBox "Fin de création des courriers !", vbInformation
Set DocWord = Nothing
Set WApp = Nothing
Set AireDocuments = Nothing
End Sub
Sub MajSignets(ByVal DocAModifier As Word.Document, ByVal CelluleEnCours As Range)
Dim ColEnCours As Integer
ColEnCours = CelluleEnCours.Column
With DocAModifier
.Bookmarks("Date_étab").Range.Text = CelluleEnCours.Offset(0, 1 - ColEnCours)
.Bookmarks("Ref").Range.Text = CelluleEnCours.Offset(0, 2 - ColEnCours)
.Bookmarks("Nom").Range.Text = CelluleEnCours.Offset(0, 3 - ColEnCours)
.Bookmarks("Prénom").Range.Text = CelluleEnCours.Offset(0, 4 - ColEnCours)
.Bookmarks("Adresse").Range.Text = CelluleEnCours.Offset(0, 5 - ColEnCours)
.Bookmarks("Complément").Range.Text = CelluleEnCours.Offset(0, 6 - ColEnCours)
.Bookmarks("CP").Range.Text = CelluleEnCours.Offset(0, 7 - ColEnCours)
.Bookmarks("Ville").Range.Text = CelluleEnCours.Offset(0, 8 - ColEnCours)
.Bookmarks("Traité_par").Range.Text = CelluleEnCours.Offset(0, 9 - ColEnCours)
End With
End Sub |
Partager