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
Bonsoir ben haj salah,

Téléchargez les fichiers joints dans le même dossier et cliquez sur le bouton pour exécuter la macro :
VB:
Sub Copier_vers_Word()
Dim Wapp As Object, Wdoc As Object, i&, j&
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
Range([Tableau1].Rows(-1), [Tableau4]).Copy 'copier
For i = Wdoc.Tables.Count To 1 Step -1
    Wdoc.Tables(i).Delete
Next i
For i = Wdoc.Paragraphs.Count To 2 Step -1
    If UCase(Wdoc.Paragraphs(i - 1).Range.Text) Like "*GAMME*" Then
        With Wdoc.Paragraphs(i).Range
            .PageSetup.Orientation = 1 'paysage
            .Paste 'coller
            .ParagraphFormat.SpaceBefore = 3
            .ParagraphFormat.SpaceAfter = 3
        End With
        For j = Wdoc.Tables(1).Rows.Count To i + 1 Step -1
            With Wdoc.Tables(1).Rows(j).Range
                If .Text Like "*#-*" Then .InsertBreak 'saut de page
            End With
        Next j
        Exit For
    End If
    Wdoc.Paragraphs(i).Range.Delete 'RAZ
Next i
Application.CutCopyMode = 0
AppActivate Wapp.Caption
End Sub
A+
 

Pièces jointes

  • 2(1).xlsm
    127.1 KB · Affichages: 7
  • p.docx
    23.1 KB · Affichages: 6

job75

XLDnaute Barbatruc
Fichier (2) si l'on veut que la 2ème page soit affichée avec :
VB:
        Wdoc.Range.Select
        Wapp.Selection.Goto What:=1, Which:=1, Count:=2 'sélection de la page 2
 

Pièces jointes

  • 2(2).xlsm
    127.2 KB · Affichages: 6
  • p.docx
    23.1 KB · Affichages: 5

ben haj salah

XLDnaute Nouveau
Bonjour,
Merci pour ce code qui fonctionne très bien.

Le problème que le tableau ne se copie pas en bonne forme, savez vous comment faire un collage spéciale de ce type:
1619764469592.png



Est il possible aussi de copier que les lignes de tableau qui contiennent de l'écriture et de ne pas copier le tableau dans le cas ou il est vide!

Merci pour votre aide :)
 

job75

XLDnaute Barbatruc
Bonjour ben haj salah,

Chez moi les 4 tableaux se copient très correctement avec les couleurs et les titres sur une ligne.

Si vous voulez autre chose joignez le fichier Excel avec les tableaux remplis comme il faut.

A+
 

ben haj salah

XLDnaute Nouveau
Voilà les deux fichier que j'utilise cher monsieur :)

Est-il possible aussi de copier que les lignes de tableau qui contiennent des informations et de ne pas copier le tableau dans le cas ou il est vide!
 

Pièces jointes

  • p.docx
    22.8 KB · Affichages: 1
  • 1.xlsm
    101 KB · Affichages: 2

job75

XLDnaute Barbatruc
Avec vos derniers fichiers on comprend bien ce qu'il faut obtenir.

Mais ça n'a pas été facile d'y arriver, voyez les fichiers joints et la macro :
VB:
Sub Copier_vers_Word()
Dim Wapp As Object, Wdoc As Object, i&, n%, r As Range, P As Range
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
For i = Wdoc.Tables.Count To 1 Step -1
    Wdoc.Tables(i).Delete
Next i
For i = Wdoc.Paragraphs.Count To 1 Step -1
    If UCase(Wdoc.Paragraphs(i).Range.Text) Like "*GAMME*" Then
        Wdoc.Paragraphs(i).Range.PageSetup.Orientation = 1 'paysage
        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
        '---cadrage---
        Wdoc.Range.Select
        Wapp.Selection.Goto What:=1, Which:=1, Count:=2 'sélection de la page 2
        Exit For
    End If
    Wdoc.Paragraphs(i).Range.Delete 'RAZ
Next i
Application.CutCopyMode = 0
AppActivate Wapp.Caption
End Sub
 

Pièces jointes

  • 1(1).xlsm
    136.4 KB · Affichages: 3
  • p.docx
    26 KB · Affichages: 2
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour ben haj salah, le forum,

Voyez ce fichier (2), je préfère cette solution, plus rapide si les tableaux sont un peu grands :
VB:
Sub Copier_vers_Word()
Dim Wapp As Object, Wdoc As Object, i&, n%, P As Range
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
For i = Wdoc.Tables.Count To 1 Step -1
    Wdoc.Tables(i).Delete
Next i
For i = Wdoc.Paragraphs.Count To 1 Step -1
    If UCase(Wdoc.Paragraphs(i).Range.Text) Like "*GAMME*" Then
        Wdoc.Paragraphs(i).Range.PageSetup.Orientation = 1 'paysage
        For n = 1 To 4
            Set P = Evaluate("Tableau" & n).Resize(, 14) '14 colonnes
            If Application.CountA(P) Then 'si le tableau n'est pas vide
                Wapp.Selection.EndKey Unit:=6 'wdStory
                Wapp.Selection.TypeParagraph 'saut de ligne
                Set P = Union(P.Rows(-1), P)
                Set P = Intersect(P.SpecialCells(xlCellTypeConstants).EntireRow, P) 'lignes non vides
                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
        '---cadrage---
        Wdoc.Range.Select
        Wapp.Selection.Goto What:=1, Which:=1, Count:=2 'sélection de la page 2
        Exit For
    End If
    Wdoc.Paragraphs(i).Range.Delete 'RAZ
Next i
Application.CutCopyMode = 0
AppActivate Wapp.Caption
End Sub
A+
 

Pièces jointes

  • 1(2).xlsm
    136.5 KB · Affichages: 1
  • p.docx
    26 KB · Affichages: 1

ZENHA ENT

XLDnaute Nouveau
Bonjour ,

c"est ben haj salah,
Je me permets de vous contacter de ce compte car j'ai eu des soucis de connexion avec l'autre compte:)
Franchement c'est de la magie votre code, je suis resté bouche bé ,quel vrai talent!
Merci pour votre aide ,surtout que ce petit projet fait partie de mon PFE .
J'ai une dernière demande est il possible de faire la même chose avec le tableau RECAP mais cette fois seulement prendre des colonnes pour former des tableaux avec, un exemple est dans les fichiers ci-joint.
Merci encore une fois :)
 

Pièces jointes

  • 1(1) (1).xlsm
    136.4 KB · Affichages: 1
  • p (1).docx
    27.5 KB · Affichages: 1

job75

XLDnaute Barbatruc
Bonjour ben haj salah, le forum,

Pour ce nouveau problème voyez le fichier (3) et cette macro :
VB:
Sub Copier_vers_Word()
Dim Wapp As Object, Wdoc As Object, i&, texte$, n%, r As Range, P As Range, Q As Range, pos&
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
Wapp.Selection.TypeParagraph 'saut de ligne
Set Q = P.Parent.Range(P(1, 3), P.Columns(3).Find("*", , xlValues, , , xlPrevious))
Q.Resize(, 3).Copy 'copier
Wapp.Selection.PasteExcelTable False, True, False 'coller
'---Nomenclature 2ème tableau---
Wapp.Selection.TypeParagraph 'saut de ligne
Set Q = P.Parent.Range(P(1, 8), P.Columns(8).Find("*", , xlValues, , , xlPrevious))
Q.Resize(, 3).Copy 'copier
Wapp.Selection.PasteExcelTable False, True, False 'coller
'---Nomenclature 3ème tableau---
Wapp.Selection.TypeParagraph 'saut de ligne
Set Q = P.Parent.Range(P(1, 11), P.Columns(11).Find("*", , xlValues, , , xlPrevious))
Q.Resize(, 3).Copy 'copier
Wapp.Selection.PasteExcelTable False, True, False 'coller
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
Wapp.Selection.TypeParagraph 'saut de ligne
Set Q = P.Parent.Range(P(1, 6), P.Columns(6).Find("*", , xlValues, , , xlPrevious))
Q.Copy 'copier
Wapp.Selection.PasteExcelTable False, True, False 'coller
'---police des 4 tableaux---
For i = 1 To 4
    Wdoc.Tables(i).Range.Font.Name = "Calibri"
    Wdoc.Tables(i).Range.Font.Size = 11
Next i
Wdoc.Range(0, 0).Select
Application.CutCopyMode = 0
AppActivate Wapp.Caption
End Sub
Sur Excel 2019 je ne suis pas parvenu à appliquer des orientations différentes sur les 2 pages.

A+
 

Pièces jointes

  • 1(3).xlsm
    140.5 KB · Affichages: 4
  • p.docx
    27.4 KB · Affichages: 6

ZENHA ENT

XLDnaute Nouveau
Cher Mr,
Merci pour votre aide.
J'ai essayé votre dernier code et il marche super bien, il manque juste un petit truc, Je veux qu'il ne copie pas les lignes de tableau vide pour le tableau outils et pour les tableaux dans nomenclature c à dire obtenir toujours un tableau sans les lignes vide. ci-dessous un exemple.


1619969123761.png
 

job75

XLDnaute Barbatruc
Et voilà comment on arrive à une superbe usine à gaz, fichier (4) :
VB:
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
 

Pièces jointes

  • 1(4).xlsm
    134.5 KB · Affichages: 3
  • p.docx
    27.4 KB · Affichages: 10

Discussions similaires

Haut Bas