XL 2010 Exporter un onglet en Word

tvhabdo

XLDnaute Occasionnel
Bonjour a tous, le Forum


J'ai un classeur et je souhaiterais exporter la feuille (onglet) TITRE DE UNE en fichier Word.doc ou au pire en .txt

Je n'ai rien trouvé dans les diférents fil du forum..!!

Merci - Pat
 

Pièces jointes

  • titre de UNE.xlsm
    10.6 KB · Affichages: 15
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour tvhabdo, Pierre,

Voyez le fichier joint et cette macro :
Code:
Sub Word()
Dim chemin$, nom$, WApp As Object
chemin = ThisWorkbook.Path & "\"
nom = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
[A1].CurrentRegion.Copy
On Error Resume Next
Set WApp = GetObject(, "Word.Application")
If WApp Is Nothing Then Set WApp = CreateObject("Word.Application")
WApp.documents(nom).Close False 'si le document est ouvert on le ferme
On Error GoTo 0
With WApp.documents.Add
    .Range.Paste
    .SaveAs chemin & nom
    If WApp.documents.Count = 1 Then .Application.Quit Else .Close
End With
Application.CutCopyMode = 0
End Sub
A+
 

Pièces jointes

  • Excel-Word(1).xlsm
    27.4 KB · Affichages: 13

tvhabdo

XLDnaute Occasionnel
Comme ceci?
Pierre
Bonjour Pierre/Tatiak

Je travaille avec la macro du fichier Titre de UNE .xlsm du post precedent
Serait il possible de modifier la macro pour obtenir cela ?
Le coller des données dans le fichier Word me donne un tableau
Je souhaiterais avoir dans mon fichier Word du texte au long car ensuite je dois faire des copier/coller, de la relecture, etc

Merci - Pat
 

job75

XLDnaute Barbatruc
Bonjour,
Je souhaiterais avoir dans mon fichier Word du texte au long
Au long ??? Si vous voulez dire du texte concaténé voyez ce fichier (2) et cette macro :
Code:
Sub Word()
Dim chemin$, nom$, c As Range, tablo, ub%, i&, x$, j%, txt$, WApp As Object
chemin = ThisWorkbook.Path & "\"
nom = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
tablo = [A1].CurrentRegion 'matrice, plus rapide
ub = UBound(tablo, 2)
For i = 1 To UBound(tablo)
    x = ""
    For j = 1 To ub
        x = x & ", " & tablo(i, j)
    Next j
    txt = txt & vbLf & Mid(x, 3)
Next i
On Error Resume Next
Set WApp = GetObject(, "Word.Application")
If WApp Is Nothing Then Set WApp = CreateObject("Word.Application")
WApp.documents(nom).Close False 'si le document est ouvert on le ferme
On Error GoTo 0
With WApp.documents.Add
    .Range.Text = Mid(txt, 2)
    .SaveAs chemin & nom
    If WApp.documents.Count = 1 Then .Application.Quit Else .Close
End With
End Sub
A+
 

Pièces jointes

  • Excel-Word(2).xlsm
    28.2 KB · Affichages: 7

tvhabdo

XLDnaute Occasionnel
Bonjour,

Au long ??? Si vous voulez dire du texte concaténé voyez ce fichier (2) et cette macro :
Code:
Sub Word()
Dim chemin$, nom$, c As Range, tablo, ub%, i&, x$, j%, txt$, WApp As Object
chemin = ThisWorkbook.Path & "\"
nom = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
tablo = [A1].CurrentRegion 'matrice, plus rapide
ub = UBound(tablo, 2)
For i = 1 To UBound(tablo)
    x = ""
    For j = 1 To ub
        x = x & ", " & tablo(i, j)
    Next j
    txt = txt & vbLf & Mid(x, 3)
Next i
On Error Resume Next
Set WApp = GetObject(, "Word.Application")
If WApp Is Nothing Then Set WApp = CreateObject("Word.Application")
WApp.documents(nom).Close False 'si le document est ouvert on le ferme
On Error GoTo 0
With WApp.documents.Add
    .Range.Text = Mid(txt, 2)
    .SaveAs chemin & nom
    If WApp.documents.Count = 1 Then .Application.Quit Else .Close
End With
End Sub
A+
Hello JOB75, Oui ça fonctionne comme je le souhaite mais dans excel j'ai ce message de DEBOGUE
en rouge

On Error GoTo 0
With WApp.documents.Add
.Range.Text = Mid(txt, 2)
.SaveAs chemin & nom
If WApp.documents.Count = 1 Then .Application.Quit Else .Close
End With
End Sub
 

tvhabdo

XLDnaute Occasionnel
Je ne peux pas vous aider car chez moi aucun bug.
JOB75
Du coup j'ai supprimer cette ligne et TOUT fonctionne MAIS
dans ton fichier tu as un tableau, alors que moi dans mon fichier de travail, j'ai tout dans la colonne A
Cet a dire
En A4, j'ai un titre
En A5, j'ai un sous titre
En A7, J'ai un tiret pour faire une sepération
Je joint un extrait de mon fichier

Merci PAT
 

Pièces jointes

  • extrait.xlsm
    21.4 KB · Affichages: 7

job75

XLDnaute Barbatruc
Code:
Sub Word()
Dim chemin$, nom$, tablo, i&, txt$, WApp As Object
chemin = ThisWorkbook.Path & "\"
nom = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
tablo = ActiveSheet.UsedRange.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 1 To UBound(tablo)
    If tablo(i, 1) <> "" Then txt = txt & vbLf & tablo(i, 1)
Next i
On Error Resume Next
Set WApp = GetObject(, "Word.Application")
If WApp Is Nothing Then Set WApp = CreateObject("Word.Application")
WApp.documents(nom).Close False 'si le document est ouvert on le ferme
On Error GoTo 0
With WApp.documents.Add
    .Range.Text = Mid(txt, 2)
    .SaveAs chemin & nom
    If WApp.documents.Count = 1 Then .Application.Quit Else .Close
End With
End Sub
 

Pièces jointes

  • extrait(1).xlsm
    20.9 KB · Affichages: 8

job75

XLDnaute Barbatruc
Bonjour tvhabdo, Pierre,

Je viens de m'apercevoir que les fichiers des posts #10 et #11 sont vérolés.

En effet vous remarquerez que dans VBA il s'est inséré une feuille parasite Feuil1 du type ThisWorkbook.

C'est peut-être la raison du bug sur .SaveAs chemin & nom.

J'ai donc reconstruit le fichier à partir d'une feuille vierge, voyez ce que donne ce fichier (2) chez vous.

A+
 

Pièces jointes

  • extrait(2).xlsm
    17.6 KB · Affichages: 10

tvhabdo

XLDnaute Occasionnel
Code:
Sub Word()
Dim chemin$, nom$, tablo, i&, txt$, WApp As Object
chemin = ThisWorkbook.Path & "\"
nom = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
tablo = ActiveSheet.UsedRange.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 1 To UBound(tablo)
    If tablo(i, 1) <> "" Then txt = txt & vbLf & tablo(i, 1)
Next i
On Error Resume Next
Set WApp = GetObject(, "Word.Application")
If WApp Is Nothing Then Set WApp = CreateObject("Word.Application")
WApp.documents(nom).Close False 'si le document est ouvert on le ferme
On Error GoTo 0
With WApp.documents.Add
    .Range.Text = Mid(txt, 2)
    .SaveAs chemin & nom
    If WApp.documents.Count = 1 Then .Application.Quit Else .Close
End With
End Sub

Hello
Merci, JOB je l'ai adapté a mon fichier et c'est TOP
Encore merci - Pat
 

Discussions similaires

Réponses
2
Affichages
215

Statistiques des forums

Discussions
311 541
Messages
2 080 545
Membres
101 238
dernier inscrit
frbhbkesvbrvjb754