Excel vers Word

momo

XLDnaute Occasionnel
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
 

Pièces jointes

  • Analyse_xld.xlsx
    11.5 KB · Affichages: 2
  • Analyse_xld.docx
    56.7 KB · Affichages: 4

job75

XLDnaute Barbatruc
Bonjour momo,

Voyez le fichier joint et la macro affectée au bouton :
VB:
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+
 

Pièces jointes

  • Analyse_xld(1).xlsm
    19.8 KB · Affichages: 9

job75

XLDnaute Barbatruc
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) :
VB:
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+
 

Pièces jointes

  • Analyse_xld(2).xlsm
    21 KB · Affichages: 6
Dernière édition:

Discussions similaires

Réponses
2
Affichages
136
Haut Bas