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
 

Fichiers joints

Dernière édition:

tvhabdo

XLDnaute Occasionnel
Bonjour Pierre, Tatiak

Le bouton fonctionne bien, , je clic, ça lance Word, mais ensuite j'ai une page blanche, on dirait que le "Copier - Coller" ne se fait pas
Merci - pat
 

tatiak

XLDnaute Barbatruc
Salut,

Avec mes tests, je n'ai pas ces effets.
Ci-joint autre version avec un simple copy/paste et vérif si le doc est encore ouvert.

Testé et fonctionnel sous PC 32 bits + Windows10 + Office 2007 32bits et sous PC 64 bits + Windows10 + Office 2016 32bits. Pour autre configuration, je ne sais pas.

Pierre
 

Fichiers joints

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+
 

Fichiers joints

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+
 

Fichiers joints

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
 

Fichiers joints

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
 

Fichiers joints

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+
 

Fichiers joints

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


Haut Bas