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
| Sub ExcelToWord()
dim WB as Workbook
dim WS as Worksheet
dim aRange as Range
dim oWord As Word.Application
dim oDoc As Word.Document
'# Définition des variables
set WB = thisWorkbook
set WS = WB.Worksheets("uneFeuille")
Set oWord = CreateObject("Word.Application")
oWord.Visible = True
aFile = "template.docx"
aPath = WB.Path & "\" & aFile
Set oDoc = oWord.Documents.Open(aPath)
'# Copier le tableau
Set aRange = WS.Range(WS.Cells(1, 1), WS.Cells(5, 5))
aRange.Copy
'# Coller le tableau
aBookmark = "unSignet"
oWord.Selection.GoTo What:=wdGoToBookmark, Name:=aBookmark
oWord.Selection.PasteAndFormat (wdPasteDefault)
'# Répéter l'entête du tableau #1
iTable = 1
oDoc.Tables(iTable).Rows(1).Select
oWord.Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
oWord.Selection.Rows.HeadingFormat = True
'# Fusionner les cellules
oDoc.Tables(iTable).Cell(1, 1).Merge mergeTo:=oDoc.Tables(iTable).Cell(2, 2)
oDoc.Tables(iTable).Cell(1, 1).VerticalAlignment = wdCellAlignVerticalCenter
aText = cleanText(oDoc.Tables(iTable).Cell(1, 1).Range.Text)
oDoc.Tables(iTable).Cell(1, 1).Range.Text = aText
End Sub
'# Fonction cleanText - La fusion des cellules entraîne l'apparition de caractères spéciaux
Function cleanText(aText As String) As String
aText = Replace(aText, Chr(160), "")
aText = Replace(aText, Chr(10), "")
aText = Replace(aText, Chr(13), "")
cleanText = aText
End Function |
Partager