Sub CopieTableauDansWord()
'NÉCESSITE LA RÉFÉRENCE MICROSOFT WORD XX.X OBJECT LIBRARY
Dim tabLarg As Variant
tabLarg = Array("", 1.38, 1.05, 2.87, 1.51, 1.97, 1.58, 0.75, 1.94, 0.75, 2.22)
'ouvrir un doc Word
On Error Resume Next
Set W = GetObject(Class:="Word.Application")
If W Is Nothing Then Set W = New Word.Application: W.Visible = True: Err.Clear
On Error GoTo 0
W.ScreenUpdating = False
On Error GoTo fin
W.Activate
W.Documents.Add
'Copie du tableau
ThisWorkbook.Sheets(1).Range("D6").CurrentRegion.Copy
Set S = W.ActiveWindow.Selection
With S
.ParagraphFormat.Alignment = 3 ' centré
.Font.Bold = True 'gras
.TypeText "Le tableau Excel"
'collage du tableau dans nouveau doc Word
'arg1 lié, arg2 mise en forme Excel = false ou Word =true, arg3 RTF = true, HTML = false
.PasteExcelTable False, False, False
.ParagraphFormat.Alignment = 3 ' aligner à gauche
.Font.Bold = True
.TypeText vbLf & "Le tableau est copié et formaté.": .Font.Bold = False: .TypeText vbLf & "fred65200"
End With
'''''chemin = ThisWorkbook.Path & Application.PathSeparator & "Loudho"
With ActiveDocument.Tables(1)
'largeur en centimetres
.PreferredWidthType = wdPreferredWidthPoints
'bordures
.Borders.Enable = True 'bordures par défaut
' .Borders.InsideLineStyle = wdLineStyleSingle
' .Borders.OutsideLineStyle = wdLineStyleSingle 'wdLineStyleDouble
'ajustement automatique
' .AutoFitBehavior wdAutoFitWindow
'hauteur de lignes
.Rows.SetHeight RowHeight:=CentimetersToPoints(0.4), HeightRule:=wdRowHeightExactly
With .Rows(1)
.SetHeight RowHeight:=CentimetersToPoints(2.45), HeightRule:=wdRowHeightExactly
'couleur de fond 1ere ligne
.Shading.BackgroundPatternColor = RGB(196, 188, 150)
'alignement
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
End With
For i = 7 To 9
.Cell(1, i).Range.Orientation = wdTextOrientationUpward
Next
'largeur colonnes
For i = 1 To .Columns.Count ' ou UBound(tabLarg)
.Columns(i).SetWidth ColumnWidth:=CentimetersToPoints(tabLarg(i)), RulerStyle:=1
Next
End With
chemin = ThisWorkbook.Path & Application.PathSeparator & "Loudho"
W.ActiveDocument.SaveAs Filename:=chemin
AppActivate "Microsoft Excel"
MsgBox "Document enregistré" & vbLf & chemin
AppActivate "Microsoft Word"
fin:
W.ScreenUpdating = True
Set W = Nothing
End Sub