Sub Copier_vers_Word()
Dim Wapp As Object, Wdoc As Object, i&, texte$, n%, r As Range, P As Range, pos&, Q As Range, num%
On Error Resume Next
Set Wapp = GetObject(, "Word.Application")
If Wapp Is Nothing Then Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
Set Wdoc = Wapp.Documents.Open(ThisWorkbook.Path & "\p.docx")
If Wdoc Is Nothing Then MsgBox "Fichier 'p.docx' introuvable !", 48: Exit Sub
On Error GoTo 0
'---suppression des tableaux---
For i = Wdoc.Tables.Count To 1 Step -1
Wdoc.Tables(i).Delete
Next i
'---tableaux 1 2 3 4---
Wdoc.PageSetup.Orientation = 1 'paysage
For i = Wdoc.Paragraphs.Count To 2 Step -1
texte = UCase(Wdoc.Paragraphs(i - 1).Range.Text)
If texte Like "*GAMME*" Then
For n = 1 To 4
Set r = Evaluate("Tableau" & n).Resize(, 14) '14 colonnes
If Application.CountA(r) Then 'si le tableau n'est pas vide
Wapp.Selection.EndKey Unit:=6 'wdStory
Wapp.Selection.TypeParagraph 'saut de ligne
Set P = r.Rows(-1)
For Each r In r.Parent.Range(P, r).Rows
If Application.CountA(r) Then Set P = Union(P, r)
Next r
P.Copy 'copier
Wapp.Selection.PasteExcelTable False, True, False 'coller
'---mises en forme---
With Wdoc.Tables(Wdoc.Tables.Count)
.AutoFitBehavior 2 'wdAutoFitWindow
.Rows.HeightRule = 0 'wdRowHeightAuto'ajustement hauteurs
End With
End If
Next n
ElseIf Not texte Like "OUTILS*" And Not texte Like "NOMENCLATURE*" Then
Wdoc.Paragraphs(i - 1).Range.Delete 'RAZ
End If
Next i
'---Nomenclature 1er tableau---
Set P = [TableauRECAP11] 'à adapter
Set P = Union(P.Rows(0), P)
pos = Wdoc.Paragraphs(2).Range.End - 1
Wdoc.Range(pos, pos).Select
Set Q = P.Parent.Range(P(1, 3), P.Columns(3).Find("*", , xlValues, , , xlPrevious))
If Application.CountA(Q) > 1 Then
num = num + 1
Wapp.Selection.TypeParagraph 'saut de ligne
Q.Resize(, 3).Copy 'copier
Wapp.Selection.PasteExcelTable False, True, False 'coller
With Wdoc.Tables(num)
For i = .Rows.Count To 2 Step -1
If Len(.Rows(i).Range) = 8 Then .Rows(i).Delete '8=2*3+2 les cellules vides du tableau Word contiennen 2 cararctères (vbCrLf)
Next i
End With
End If
'---Nomenclature 2ème tableau---
Set Q = P.Parent.Range(P(1, 8), P.Columns(8).Find("*", , xlValues, , , xlPrevious))
If Application.CountA(Q) > 1 Then
num = num + 1
Wapp.Selection.TypeParagraph 'saut de ligne
Q.Resize(, 3).Copy 'copier
Wapp.Selection.PasteExcelTable False, True, False 'coller
With Wdoc.Tables(num)
For i = .Rows.Count To 2 Step -1
If Len(.Rows(i).Range) = 8 Then .Rows(i).Delete '8=2*3+2 chaque cellule vide du tableau Word contient 2 caractères (vbCrLf)
Next i
End With
End If
'---Nomenclature 3ème tableau---
Set Q = P.Parent.Range(P(1, 11), P.Columns(11).Find("*", , xlValues, , , xlPrevious))
If Application.CountA(Q) > 1 Then
num = num + 1
Wapp.Selection.TypeParagraph 'saut de ligne
Q.Resize(, 3).Copy 'copier
Wapp.Selection.PasteExcelTable False, True, False 'coller
With Wdoc.Tables(num)
For i = .Rows.Count To 2 Step -1
If Len(.Rows(i).Range) = 8 Then .Rows(i).Delete '8=2*3+2 chaque cellule vide du tableau Word contient 2 caractères (vbCrLf)
Next i
End With
End If
Wapp.Selection.Delete 'supprime le dernier saut de ligne
Wapp.Selection.InsertBreak 'saut de page en fin de tableau
'---Outils---
pos = Wdoc.Paragraphs(1).Range.End - 1
Wdoc.Range(pos, pos).Select
Set Q = P.Parent.Range(P(1, 6), P.Columns(6).Find("*", , xlValues, , , xlPrevious))
If Application.CountA(Q) > 1 Then
num = num + 1
Wapp.Selection.TypeParagraph 'saut de ligne
Q.Copy 'copier
Wapp.Selection.PasteExcelTable False, True, False 'coller
With Wdoc.Tables(1)
For i = .Rows.Count To 2 Step -1
If Len(.Rows(i).Range) = 4 Then .Rows(i).Delete '4=2*1+2 chaque cellule vide du tableau Word contient 2 caractères (vbCrLf)
Next i
End With
End If
'---police des 4 tableaux---
For i = 1 To num
With Wdoc.Tables(i).Range
.Font.Name = "Calibri"
.Font.Size = 11
For n = 2 To .Rows.Count
.Rows(n).Range.Font.Bold = False 'non gras
Next n
End With
Next i
Wdoc.Range(0, 0).Select
Application.CutCopyMode = 0
AppActivate Wapp.Caption
End Sub