Excel vers Word

[momo]

Bonjour à tous

Je viens vers vous pour m'aider sur un projet.

j'ai un classeur Excel avec des tableaux et quelques commentaires en bas de chaque tableaux.
L'objectif est de transférer dans l'intégral tous les tableaux et commentaires vers un fichier Word.
Je demande votre assistance et je joins le fichier excel et le Word qui montre le résultat attendu

 

[job75]

Bonjour momo,

Voyez le fichier joint et la macro affectée au bouton :

Sub Word()
Dim chemin$, doc$, Wapp As Object
chemin = ThisWorkbook.Path & "\" 'à adapter
doc = "Analyse_xld.docx" 'à adapter
On Error Resume Next
Set Wapp = GetObject(, "Word.Application")
If Wapp Is Nothing Then Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
Wapp.Documents(doc).Close False 'si le document Word est ouvert on le ferme
ActiveSheet.UsedRange.Copy 'copier
With Wapp.Documents.Add 'document vierge
    .Range.Paste 'coller
    .SaveAs chemin & doc 'enregistre
End With
Application.CutCopyMode = 0
End Sub

A+

 

[laurent3372]

Bonjour momo,
Est-ce volontairement que les tableau Excel sont recopiés en tant qu'objets modifiables dans le fichier Word ?
Ne serait-ce pas mieux de recopier une image (non modifiable) des tableaux ?

 

[momo]

Voyez le fichier joint et la macro affectée au bouton

C'est Genial!!!
Par contre le texte lui même arrive sous forme de tableau (Certes sans bordures). Mais ca pourrait compliquer certains ajouts
Merci Job

 

[momo]

Ne serait-ce pas mieux de recopier une image (non modifiable) des tableaux ?

Bonjour Laurent!
En effet en image également ce serait bien. A partir du moment ou il se présentent correctement dans le fichier word
momo

 

[laurent3372]

Pas plus que mettre un objet Excel modifiable dans un fichier Word

 

[job75]

Bonjour momo, le forum,

Par contre le texte lui même arrive sous forme de tableau (Certes sans bordures). Mais ca pourrait compliquer certains ajouts

Oui et pour y remédier on peut fusionner avant le copier-coller les lignes entre les tableaux c'est à dire les plages A7:F7 A8:F8 A9:F9 etc... et les défusionner ensuite, voyez ce fichier (2) :

Sub Word()
Dim chemin$, doc$, Wapp As Object, i&
chemin = ThisWorkbook.Path & "\" 'à adapter
doc = "Analyse_xld.docx" 'à adapter
On Error Resume Next
Set Wapp = GetObject(, "Word.Application")
If Wapp Is Nothing Then Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
Wapp.Documents(doc).Close False 'si le document Word est ouvert on le ferme
With ActiveSheet.UsedRange
    '---fusionne les lignes entre les tableaux---
    For i = 1 To .Rows.Count
        If .Cells(i, 1) = "Désignation" Then i = i + .Cells(i, 1).CurrentRegion.Rows.Count
        .Rows(i).Merge
    Next
    '---copier-coller dans Word---
    .Copy 'copier
    With Wapp.Documents.Add 'document vierge
        .Range.Paste 'coller
        .SaveAs chemin & doc 'enregistre
    End With
    '---défusionne les lignes entre les tableaux---
    For i = 1 To .Rows.Count
        If .Cells(i, 1) = "Désignation" Then i = i + .Cells(i, 1).CurrentRegion.Rows.Count
        .Rows(i).UnMerge
    Next
End With
End Sub

A+

 

[momo]

Ça fait 5 ans que vous m’aidez sur mes différents sujets et et ça fait 5 ans que je ne cesse d’être sous le charme de chacun de vos apports
Vraiment merci beaucoup le fichier est impeccable