XL 2019 Copier /coller Excel word

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
B

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
    2.xlsm
    95.5 KB · Affichages: 19
  • p.docx
    p.docx
    22.8 KB · Affichages: 11
Solution
job75
Bon j'ai trouvé, le bouclage n'était pas dû aux images.

Il provenait du fait que dans le fichier Word en 2ème page (Nomenclature) les sauts de ligne n'allaient pas jusqu'en bas de la page, un saut de page avait été inséré.

Utilisez le fichier Word joint; il n'y a plus de problème de bouclage.
Trier par date Trier par votes
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

Dernière édition:
Vote positif 0 Vote négatif
job75 à dit:
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
Cliquez pour agrandir...
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
    p.docx
    25.9 KB · Affichages: 2
Vote positif 0 Vote négatif
ben haj salah à dit:
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
Cliquez pour agrandir...

ben haj salah à dit:
Même chose pour la partie gamme en important les 4 tableaux les titres dans les pages juste après s'efface🙁
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
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

Vote positif 0 Vote négatif
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

Vote positif 0 Vote négatif
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

Dernière édition:
Vote positif 0 Vote négatif
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+
 
Vote positif 0 Vote négatif
Bon j'ai trouvé, le bouclage n'était pas dû aux images.

Il provenait du fait que dans le fichier Word en 2ème page (Nomenclature) les sauts de ligne n'allaient pas jusqu'en bas de la page, un saut de page avait été inséré.

Utilisez le fichier Word joint; il n'y a plus de problème de bouclage.
 

Pièces jointes

  • p.docx
    p.docx
    26.6 KB · Affichages: 11
Vote positif 0 Vote négatif
Solution
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

adel.benmahmoud79
  • Question Question
XL 2010 400 fichier Word à insérer sur Excel
Réponses
4
Affichages
112
Staple1600
Staple1600
X
  • Question Question
XL 2021 Génération word à partir d'excel en gardant le format source
Réponses
8
Affichages
137
xlym
X
N
  • Question Question
Microsoft 365 Choisir une imprimante pour imprimer doc word sous VBA Excel
Réponses
2
Affichages
81
natof
N
C
  • Résolu(e)
Microsoft 365 Copie texte de word vers Excel
Réponses
10
Affichages
400
chax
C
P
  • Question Question
Microsoft 365 VBA copier-coller selon conditions
Réponses
4
Affichages
100
vgendron
vgendron
A
  • Question Question
XL 2021 Automatiser la génération de documents Word à partir d’Excel avec VBA
Réponses
12
Affichages
299
ali591
A
chinel
  • Résolu(e)
XL 2016 copier/coller en VBA
Réponses
11
Affichages
238
chinel
chinel
J
  • Question Question
Microsoft 365 Naviguer dans un tableau pour copier des données dans un modèle et copier l'un derrière l'autre
Réponses
11
Affichages
171
AtTheOne
AtTheOne
A
  • Question Question
XL 2019 copier un tableau Excel dans un document word
Réponses
2
Affichages
365
chris
chris
G
  • Question Question
XL 2021 Macro pour changer les titres de fichier d'archive
Réponses
3
Affichages
109
fanch55
fanch55
B
  • Question Question
XL 2021 Transfert tableau structuré EXCEL à un endroit précis de WORD
Réponses
8
Affichages
913
job75
job75
Mathos
  • Résolu(e)
XL 2021 Copie de certaines données Excel sur Word
2
Réponses
28
Affichages
915
Mathos
Mathos
P
  • Résolu(e)
Microsoft 365 Copier coller les mêmes valeurs dans la même cellule
Réponses
12
Affichages
277
job75
job75
I
  • Résolu(e)
Microsoft 365 Copier-coller dans une plage avec des cellules masquées
Réponses
6
Affichages
226
sylvanu
sylvanu
S
  • Résolu(e)
XL 2013 Copier-Coller une ligne dans tableau variable, et la manipuler.
Réponses
4
Affichages
93
StéphaneDeLà
S
P
  • Résolu(e)
XL 2016 VBA Insérer une date dans le nom de fichiers PDF publipostés via WORD à partir d"excel
Réponses
3
Affichages
57
PHIL37
P
P
  • Résolu(e)
XL 2021 Besoin d'aide pour copier/coller données de plusieurs classeurs
2
Réponses
20
Affichages
838
Pac41240
P
alexandre33260
  • Résolu(e)
XL 2021 Copie cellules Excel vers Word avec mise à jour automatique
2
Réponses
29
Affichages
2 K
alexandre33260
alexandre33260
N
  • Question Question
Microsoft 365 afficher/masquer des lignes en fonction de la valeur d'une cellule qui aura été renseignée par une autre feuille (via un copier/collé automatique)
Réponses
5
Affichages
538
Nel'
N
C
  • Question Question
XL 2019 vba excel : masquer un tableau word
Réponses
9
Affichages
714
CBX
C
Retour