XL 2019 Copier /coller Excel word

Sub Copier_vers_Word()
Dim Wapp As Object, Wdoc As Object, i&, texte$, n%, r As Range, P As Range, pos&, col%, 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---
Set P = [TableauRECAP11] 'à adapter
Set P = Union(P.Rows(0), P)
pos = Wdoc.Paragraphs(2).Range.End - 1
Wdoc.Range(pos, pos).Select
For n = 1 To 3
    col = Choose(n, 3, 8, 11)
    Set Q = P.Parent.Range(P(1, col), P.Columns(col).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
Next n
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 n = 1 To num
    With Wdoc.Tables(n)
        .Range.Font.Name = "Calibri"
        .Range.Font.Size = 11
        .Range.Font.Bold = False 'non gras
        .Rows(1).Range.Font.Bold = True 'gras
    End With
Next n
Wdoc.Range(0, 0).Select
Application.CutCopyMode = 0
AppActivate Wapp.Caption
End Sub

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

        '---copie les images---
        For i = 2 To .Rows.Count
            If .Cell(i, 14).Range Like "_###*" Then
                .Rows(i).Height = 35 'hauteur à adapter
                nom = Left(.Cell(i, 14).Range, 4)
                P.Parent.Shapes(nom).Copy
                .Cell(i, 14).Range.Paste 'colle l'image
                Wdoc.Shapes(nom).Height = .Rows(i).Height - 2
            End If
        Next i

    '---copie les images---
    If colonneImage Then
        For i = 2 To .Rows.Count
            Set r = .Cell(i, colonneImage).Range
            If r Like "_###*" Then
                .Rows(i).Height = 35 'hauteur à adapter
                r.ParagraphFormat.Alignment = 1 'wdAlignParagraphCenter
                nom = Left(r, 4)
                P.Parent.Shapes(nom).Copy
                r.Paste 'colle l'image
                Set o = Wdoc.Shapes(nom)
                o.Height = .Rows(i).Height - 4
                o.Top = o.Top + 2
                o.RelativeHorizontalPosition = 3 'wdRelativeHorizontalPositionCharacter
                o.Left = -o.Width / 2 'centrage horizontal
            End If
        Next i
    End If