XL 2019 Copier /coller Excel word

ben haj salah · 29 Avril 2021

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,

job75 · 29 Avril 2021

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+

job75 · 29 Avril 2021

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

ben haj salah · 30 Avril 2021

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:

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 · 30 Avril 2021

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 · 30 Avril 2021

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!

job75 · 30 Avril 2021

Vous plaisantez ? Ce sont les mêmes fichiers !

Il faudrait des tableaux avec des lignes remplies et des lignes vides.

Et au moins un tableau entièrement vide.

ben haj salah · 30 Avril 2021

Voila un exemple de ce que je cherche à faire exactement, si le tableau est rempli je prend que les lignes remplies sinon je le prends pas

job75 · 30 Avril 2021

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

job75 · 1 Mai 2021

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+

job75 · 1 Mai 2021

En fait je viens de tester avec un tableau de 2000 lignes dont 1000 remplies.

Que les lignes remplies soient disjointes ou jointives le fichier (2) n'est pas plus rapide que le (1)

ZENHA ENT · 1 Mai 2021

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

job75 · 2 Mai 2021

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+

ZENHA ENT · 2 Mai 2021

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.

job75 · 2 Mai 2021

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

XL 2019 Copier /coller Excel word

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Partager cette page

Statistiques des forums