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
Bonjour Pierre/TatiakComme ceci?
Pierre
Au long ??? Si vous voulez dire du texte concaténé voyez ce fichier (2) et cette macro :Je souhaiterais avoir dans mon fichier Word du texte au long
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
Hello JOB75, Oui ça fonctionne comme je le souhaite mais dans excel j'ai ce message de DEBOGUEBonjour,
Au long ??? Si vous voulez dire du texte concaténé voyez ce fichier (2) et cette macro :
A+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
JOB75Je ne peux pas vous aider car chez moi aucun bug.
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
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
Alors .SaveAs chemin & nom fonctionne chez vous ?Merci, JOB je l'ai adapté a mon fichier et c'est TOP