XL 2019 Copier /coller Excel word

ben haj salah

XLDnaute Nouveau
Bonjour,

Je cherche une macro qui me permet de copier les 4 premiers tableaux de la colonne (H à N) dans le fichier 2.xlsm et les coller dans le document p.dox (word )l'un après l'autre juste après le titre 1. GAMME dans le fichier word.
CELA EST IL POSSIBLE !
Merci à vous,
 

Pièces jointes

  • 2.xlsm
    95.5 KB · Affichages: 3
  • p.docx
    22.8 KB · Affichages: 6

job75

XLDnaute Barbatruc
Dans ce fichier (5) j'ai regroupé les codes de Nomenclature, ça ne change rien mais c'est plus court :
VB:
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
 

Pièces jointes

  • 1(5).xlsm
    133.5 KB · Affichages: 6
  • p.docx
    27.4 KB · Affichages: 2
Dernière édition:

ben haj salah

XLDnaute Nouveau
Dans ce fichier (5) j'ai regroupé les codes de Nomenclature, ça ne change rien mais c'est plus court :
VB:
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
Bonjour Mr,
J'espère que vous allez bien !
J'ai un petit souci avec ce code, une fois que j'ai rajouté deux tableaux avant le titre outils ,la macro me supprime directement ces tableaux y'as-il moyen de garder la même mise en page de document Word ci-joint !
Merci d'avance,
 

Pièces jointes

  • p.docx
    25.9 KB · Affichages: 1

ben haj salah

XLDnaute Nouveau
Bonjour Mr,
J'espère que vous allez bien !
J'ai un petit souci avec ce code, une fois que j'ai rajouté deux tableaux avant le titre outils ,la macro me supprime directement ces tableaux y'as-il moyen de garder la même mise en page de document Word ci-joint !
Merci d'avance

Même chose pour la partie gamme en important les 4 tableaux les titres dans les pages juste après s'efface:(
 

job75

XLDnaute Barbatruc
Bonjour ben haj salah, le forum,

Je reviens sur ce fil car le dernier problème posé est vraiment intéressant bien que très difficile.

Voyez ce fichier (6) et les 4 macros (3 sont paramétrées) :
VB:
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
Bien voir que dans le fichier Word P il y a les 4 signets nommés Outils Nomenclature GAMME et Schema.

Les traitements sont assez lourds et prennent du temps : 9,7 secondes chez moi sur Excel 2019.

A+
 

Pièces jointes

  • 1(6).xlsm
    155.9 KB · Affichages: 1
  • p.docx
    26 KB · Affichages: 0

job75

XLDnaute Barbatruc
Il n'est pas très difficile d'insérer des images dans des tableaux Word.

Dans ce fichier (7) j'ai renommé les images _001, _002 etc... et mis leurs noms dans leurs cellules.

Et ajouté ce code dans la macro Coller :
VB:
        '---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
 

Pièces jointes

  • 1(7).xlsm
    254 KB · Affichages: 0
  • p.docx
    26 KB · Affichages: 0

job75

XLDnaute Barbatruc
Comme il y a des images dans le tableau RECAP j'ai ajouté une colonne au 3ème tableau de Nomenclature.

J'ai ajouté l'argument colonneImage dans la macro Coller, voyez ce fichier (8) et le code :
VB:
    '---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
Nota : chez moi si l'on passe la hauteur de ligne de 35 à 40 la 3ème page passe en orientation Portrait.

Edit : ajouté le centrage horizontal de l'image.
 

Pièces jointes

  • 1(8).xlsm
    272.7 KB · Affichages: 4
  • p.docx
    26 KB · Affichages: 4
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour ben haj salah, le forum,

Chez moi il se passe un phénomène étrange avec le fichier (8).

Lorsque que je relance la macro alors que que le fichier Word est ouvert il arrive (pas toujours) que la macro boucle sans fin, je suis obligé de sortir avec le Gestionnaire des tâches.

D'évidence ce phénomène est dû aux images (Shapes) mais même quand je les supprime du fichier Word dès le début il arrive quand même qu'il y ait bouclage.

Pas trouvé de remède pour l'instant.

A+
 

Discussions similaires

Haut Bas