copying sheets into Word

[lezawang]

Hi
I have excel file which has multiple sheets. each sheet has text and pictures. The text is simple one each line written in one cell and each sheet has several lines of text. I want to copy all these sheets, 20 of them into Microsoft word. What I did, I grouped all sheets and then Ctrl+A the first sheet and then paste it in Word. But only sheet1 got copied. Any idea how I can copy them all at one shot? Thank you very much.

 

[NdNoviceHlp]

Hi lezawang. You can give this a trial. Change the Word doc file path to suit. HTH. Dave
Module code....

Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Public Declare Function CloseClipboard Lib "user32" () As Long
    Public Declare Function EmptyClipboard Lib "user32" () As Long

Sheet code...

Sub SaveXlRangeToWordFile()
Dim Ws As Worksheet, WidthAvail As Double
Dim WdDoc As Object, WdApp As Object, Cnt As Integer
'open Word application
On Error Resume Next
Set WdApp = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set WdApp = CreateObject("Word.Application")
End If
'open doc **********change file path to suit
On Error GoTo erfix
Set WdDoc = WdApp.Documents.Open(Filename:="C:\yourfoldername\bart.docx")
'clear doc
With WdApp.ActiveDocument
    .Range(0, .Characters.Count).Delete
End With
'determine width
With WdApp.ActiveDocument.PageSetup
    WidthAvail = .PageWidth - .LeftMargin - .RightMargin
End With
'loop sheets
For Each Ws In ActiveWorkbook.Worksheets
Cnt = Cnt + 1
Application.StatusBar = "Copying data from " & Ws.Name & "..."
Ws.UsedRange.Copy
WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range.PasteSpecial DataType:=3 '9  '4
'size range to sheet
With WdDoc.Shapes(Cnt)
.LockAspectRatio = msoFalse
.Width = WidthAvail
End With
Application.CutCopyMode = False
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
'paste to seperate page
WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range.InsertParagraphAfter
If Not Ws.Name = Worksheets(Worksheets.Count).Name Then
With WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range
.InsertParagraphAfter
.Collapse Direction:=0 'wdCollapseEnd
.InsertBreak Type:=7 'wdPageBreak
End With
End If
Next Ws
'clean up
WdApp.ActiveDocument.Close savechanges:=True
Set WdDoc = Nothing
WdApp.Quit
Set WdApp = Nothing
Application.StatusBar = False
Exit Sub

erfix:
On Error GoTo 0
MsgBox "Save SaveXlRangeToWordFile error"
WdApp.ActiveDocument.Close savechanges:=False
Set WdDoc = Nothing
WdApp.Quit
Set WdApp = Nothing
Application.CutCopyMode = False
Application.StatusBar = False
End Sub

 

[lezawang]

Thank you. I appreciate the help.

 

[Macropod]

Much simpler - and in all likelihood faster:

Sub SendExcelSheetsToWordDocument()
'Note: This code requires a VBA reference to be set to Word, via Tools|References.
Dim StrNm As String
StrNm = "C:\Users\" & Environ("UserName") & "\Documents\Filename.docx"
If Dir(StrNm, vbNormal) = "" Then
  MsgBox "Cannot Find: " & StrNm: Exit Sub
End If
Dim xlWs As Worksheet, WdApp As New Word.Application, WdDoc As Word.Document
WdApp.Visible = False
Set WdDoc = WdApp.Documents.Open(Filename:=StrNm, AddToRecentFiles:=False)
For Each xlWs In ThisWorkbook.Worksheets
  Application.StatusBar = "Processing: " & xlWs.Name
  xlWs.UsedRange.Copy
  With WdDoc
    .Range.InsertAfter Chr(12)
    .Characters.Last.Paste
  End With
Next
Application.StatusBar = False
WdDoc.Close SaveChanges:=True: WdApp.Quit
Set WdDoc = Nothing: Set WdApp = Nothing: Set xlWs = Nothing
End Sub

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. Be safe. Dave