Sub Copier_vers_Word()
Dim Wapp As Object, Wdoc As Object, signet, F As Worksheet, num%, pos&, P As Range, Q As Range, num0%, n%, col%
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
signet = Array("Outils", "Nomenclature", "GAMME", "Schema") 'liste dans l'ordre des signets Word à utiliser
Application.ScreenUpdating = False
Set F = Workbooks.Add.Sheets(1) 'document auxiliaire
ThisWorkbook.Activate
'---tableau Outils---
Call SupprimerTableaux(Wdoc, signet(0), signet(1), num) 'lance la macro
pos = Wdoc.Bookmarks(signet(0)).Range.End + 1
Wdoc.Range(pos, pos).Select
num0 = num
Set P = [TableauRECAP11] 'à adapter
Set Q = P.Columns(6)
Call Coller(Q, num, F, False, False, Wapp, Wdoc, True) 'lance la macro
If num - num0 Then Wdoc.Range(pos - 1, pos - 1).Delete
Call Epurer(Wdoc, signet(1)) 'lance la macro
'---tableaux Nomenclature---
Call SupprimerTableaux(Wdoc, signet(1), signet(2), num) 'lance la macro
pos = Wdoc.Bookmarks(signet(1)).Range.End + 1
Wdoc.Range(pos, pos).Select
num0 = num
For n = 1 To 3
col = Choose(n, 3, 8, 11)
Set Q = P.Columns(col).Resize(, 3)
Call Coller(Q, num, F, False, False, Wapp, Wdoc, True) 'lance la macro
Next n
If num - num0 Then Wdoc.Range(pos - 1, pos - 1).Delete
Call Epurer(Wdoc, signet(2)) 'lance la macro
'---tableaux 1 2 3 4---
Call SupprimerTableaux(Wdoc, signet(2), signet(3), num) 'lance la macro
pos = Wdoc.Bookmarks(signet(2)).Range.End + 1
Wdoc.Range(pos, pos).Select
num0 = num
For n = 1 To 4
Set P = Evaluate("Tableau" & n).Resize(, 14) '14 colonnes
Call Coller(P, num, F, True, True, Wapp, Wdoc, False) 'lance la macro
Next n
If num - num0 Then Wdoc.Range(pos - 1, pos - 1).Delete
Call Epurer(Wdoc, signet(3)) 'lance la macro
Wdoc.Range(0, 0).Select
F.Parent.Close False 'ferme le document auxiliaire
AppActivate Wapp.Caption
End Sub
Sub SupprimerTableaux(Wdoc As Object, signet0, signet1, num%)
Dim deb&, fin&, n%, pos&, r As Object, page%
num = 0
deb = Wdoc.Bookmarks(signet0).Range.End
fin = Wdoc.Bookmarks(signet1).Range.Start
For n = Wdoc.Tables.Count To 1 Step -1
pos = Wdoc.Tables(n).Range.Start
If pos >= deb And pos < fin Then
Wdoc.Tables(n).Delete 'supprime le tableau
Set r = Wdoc.Bookmarks(signet1).Range
page = r.Information(1) '1=wdActiveEndAdjustedPageNumber
'---déplace le signet1 sur la page suivante---
If Wdoc.Range(deb, deb).Information(1) = page Then
While r.Information(1) < page + 1
Wdoc.Range(deb, deb) = Wdoc.Range(deb, deb) & vbCrLf 'ajoute des sauts de ligne
Wend
End If
End If
If pos < deb Then num = num + 1 'compte les tableaux précédents
Next n
End Sub
Sub Coller(P As Range, num%, F As Worksheet, titre2 As Boolean, AjouteLigneAvant As Boolean, Wapp As Object, Wdoc As Object, ColumnAutofit As Boolean)
If Application.CountA(P) = 0 Then Exit Sub
num = num + 1
If titre2 Then Set P = Union(P.Rows(-1), P.Rows(0), P) Else Set P = Union(P.Rows(0), P)
F.[B1].Resize(P.Rows.Count, P.Columns.Count) = P.Value
With F.UsedRange.Columns(0)
.FormulaR1C1 = "=IF(COUNTA(RC2:RC" & P.Columns.Count + 1 & "),1,"""")"
.Value = .Value 'supprime les formules
F.UsedRange.Sort .Cells, xlAscending
.ClearContents
End With
If titre2 Then F.UsedRange.Rows(1).Merge 'cellules fusionnées
If AjouteLigneAvant Then Wapp.Selection.TypeParagraph 'saut de ligne
F.UsedRange.Copy 'copier
Wapp.Selection.PasteExcelTable False, True, False 'coller
F.UsedRange.Clear
If Not AjouteLigneAvant Then Wapp.Selection.TypeParagraph 'saut de ligne
'---mises en forme---
With Wdoc.Tables(num)
If ColumnAutofit Then .Columns.AutoFit Else .AutoFitBehavior 2 'wdAutoFitWindow
.Rows.HeightRule = 0 'wdRowHeightAuto'ajustement hauteurs
.Range.Font.Name = "Calibri"
.Range.Font.Size = 11
.Range.Font.Bold = False 'non gras
.Rows(1).Range.Font.Bold = True 'gras
If titre2 Then .Rows(2).Range.Font.Bold = True 'gras
End With
End Sub
Sub Epurer(Wdoc As Object, signet)
Dim pos&, r As Object, page%, Wapp As Object, test As Boolean
pos = Wdoc.Bookmarks(signet).Range.Start - 1
Set r = Wdoc.Range(pos, pos)
page = r.Information(1) '1=wdActiveEndAdjustedPageNumber
Set Wapp = Wdoc.Application
If Wapp.Selection.Information(1) >= page Then Exit Sub
'---déplace le signet sur la page précédente---
While r.Information(1) > page - 1
Wapp.Selection.Delete
Wend
End Sub
