I keep getting the 462 error the second or third time I run this loop. I don't think I have any objects that are floating but maybe I missed something, I am kind of new at this. This macro is taking all the charts from Excel, pasting them into Word as pictures, resizing them, saving the document and closing it. The For loop has formatting for the chart to be pasted as a normal picture and the text below it to be caption so I can create a figure table easily.
The error takes place in the .Height = InchesToPoints(6.1) line.
Private Sub ChartstoWord_Click()
Dim WDApp As Word.Application
Dim WDDoc As Word.Document
Dim cname, wordname, restage, pNumber, wfile As String
Dim n As Integer
Dim i As Long
Application.ScreenUpdating = False
If wordfile.Value = "" Then
MsgBox "Please enter a word file name", vbOKOnly
Exit Sub
End If
wfile = CurveDirectoryBox & "\" & wordfile.Value & ".docx"
wordname = UCase(dataname.Value)
'if word file doesn't exist then it makes the word file for you
If Dir(wfile) = "" Then
Set WDApp = CreateObject("Word.application")
WDApp.Visible = True
Set WDDoc = WDApp.Documents.Add
WDApp.Visible = True
With WDDoc
.SaveAs wfile
.Close
End With
Set WDDoc = Nothing
WDApp.Quit
Set WDApp = Nothing
End If
' Create new instance of Word and open filename provided if file exists
Set WDApp = CreateObject("Word.application")
WDApp.Visible = True
WDApp.Documents.Open wfile
WDApp.Visible = True
Set WDDoc = WDApp.ActiveDocument
With WDDoc
.Range(start:=.Range.End - 1, End:=.Range.End - 1).Select
.PageSetup.Orientation = wdOrientLandscape
End With
For n = 1 To Charts.Count
Charts(n).Select
cname = ActiveChart.ChartTitle.Characters.Text
ActiveChart.CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
' Paste chart at end of current document
WDApp.Visible = True
With WDApp
.Selection.Style = WDApp.ActiveDocument.Styles("Normal")
.Selection.Font.Size = 12
.Selection.Font.Bold = True
.Selection.PasteSpecial Link:=False, Placement:=wdInLine, DisplayAsIcon:=False, DataType:=wdPasteEnhancedMetafile
.Selection.TypeParagraph
.Selection.Style = WDApp.ActiveDocument.Styles("Caption")
.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Selection.Font.Size = 12
.Selection.Font.Bold = False
.Selection.TypeText (wordname + " " + cname)
.Selection.TypeParagraph
End With
Next n
'resize all pictures
WDApp.Visible = True
With WDApp
With WDDoc
For i = 1 To WDApp.ActiveDocument.InlineShapes.Count
With WDApp.ActiveDocument.InlineShapes(i)
'.Width = InchesToPoints(7.9)
.Height = InchesToPoints(6.1)
End With
Next i
End With
End With
WDDoc.Save
WDDoc.Close
Set WDDoc = Nothing
WDApp.Quit
Set WDApp = Nothing
Worksheets("Control").Activate
Range("A1").Select
Application.ScreenUpdating = True
End Sub
I was able to solve the problem, ended up being that the command InchesToPoints is a word command and needs the wdapp in front of it. Thanks for all the suggestions, I also cleaned up a code a bit after all your receommendations.
Private Sub ChartstoWord_Click()
Dim WDApp As Word.Application
Dim cname, wordname, restage, pNumber, wfile As String
Dim n As Integer
Dim i, h As Long
Application.ScreenUpdating = False
If wordfile.Value = "" Then
MsgBox "Please enter a word file name", vbOKOnly
Exit Sub
End If
wfile = CurveDirectoryBox & "\" & wordfile.Value & ".docx"
wordname = UCase(dataname.Value)
'if word file doesn't exist then it makes the word file for you
If Dir(wfile) = "" Then
Set WDApp = CreateObject("Word.application")
WDApp.Visible = True
WDApp.Documents.Add
WDApp.ActiveDocument.SaveAs wfile
WDApp.ActiveDocument.Close
WDApp.Quit
Set WDApp = Nothing
End If
' Create new instance of Word and open filename provided if file exists, checks to see if file is open or not already
If IsFileOpen(wfile) = False Then
Set WDApp = CreateObject("Word.application")
WDApp.Visible = True
WDApp.Documents.Open wfile
End If
If IsFileOpen(wfile) = True Then
Set WDApp = GetObject(wfile).Application
WDApp.Visible = True
End If
'moves cursor in word to the end of the document and change page to landscape
WDApp.ActiveDocument.Range(start:=WDApp.ActiveDocument.Range.End - 1, End:=WDApp.ActiveDocument.Range.End - 1).Select
WDApp.ActiveDocument.PageSetup.Orientation = wdOrientLandscape
'loops through all charts and pastes them in word
For n = 1 To Charts.Count
Charts(n).Select
cname = ActiveChart.ChartTitle.Characters.Text
ActiveChart.CopyPicture Appearance:=xlScreen, Format:=xlPicture
WDApp.Visible = True
WDApp.Selection.Style = WDApp.ActiveDocument.Styles("Normal")
WDApp.Selection.Font.Size = 12
WDApp.Selection.Font.Bold = True
WDApp.Selection.PasteSpecial Link:=False, Placement:=wdInLine, DisplayAsIcon:=False, DataType:=wdPasteEnhancedMetafile
WDApp.Selection.TypeParagraph
WDApp.Selection.Style = WDApp.ActiveDocument.Styles("Caption")
WDApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
WDApp.Selection.Font.Size = 12
WDApp.Selection.Font.Bold = False
WDApp.Selection.TypeText (wordname + " " + cname)
WDApp.Selection.TypeParagraph
Next n
'resize all pictures
WDApp.Visible = True
For i = 1 To WDApp.ActiveDocument.InlineShapes.Count
WDApp.ActiveDocument.InlineShapes(i).Select
WDApp.ActiveDocument.InlineShapes(i).Height = WDApp.InchesToPoints(6.1)
Next i
WDApp.ActiveDocument.SaveAs wfile
WDApp.ActiveDocument.Close
WDApp.Quit
Set WDApp = Nothing
Worksheets("Control").Activate
Range("A1").Select
Application.ScreenUpdating = True
End Sub
Definitly too much With, and not even used, so here is a version of your resize that should be cleaner but not sure that it'll be enough, give it a try
Too many WDApp.Visible = True also, only one will be enough but as you close it after, you should even set it to False!
'resize all pictures
For i = 1 To WDDoc.InlineShapes.Count
With WDDoc.InlineShapes(i)
'.Width = InchesToPoints(7.9)
.Height = InchesToPoints(6.1)
End With
Next i
Related
Hi the following code extracts all instances of bold text from the active Word document and copies it to a newly created Word document.
Can anyone please help me to adjust the code to perform the same task on all open Word documents into the newly created Word document.
Any help is very much appreciated.
Sub A__GrabTheBolds()
On Error GoTo cleanUp
Application.ScreenUpdating = False
Dim ThisDoc As Document
Dim ThatDoc As Document
Dim r As Range
Set ThisDoc = ActiveDocument
Set r = ThisDoc.Range
Set ThatDoc = Documents.Add
With r
With .Find
.Text = ""
.Format = True
.Font.Bold = True
End With
Do While .Find.Execute(Forward:=True) = True
'If r.HighlightColorIndex = wdDarkYellow Then 'highlightcols(7)
If r.Bold Then
ThatDoc.Range.Characters.Last.FormattedText = .FormattedText
ThatDoc.Range.InsertParagraphAfter
.Collapse 0
End If
Loop
End With
cleanUp:
Application.ScreenUpdating = True
Set ThatDoc = Nothing
Set ThisDoc = Nothing
End Sub
You can use the Documents-collection which returns all open documents:
Sub A__GrabTheBolds()
On Error GoTo cleanUp
Application.ScreenUpdating = False
Dim ThisDoc As Document
Dim ThatDoc As Document
Dim r As Range
Set ThatDoc = Documents.Add
'iterate over all open word documents
'For Each ThisDoc In Application.Documents
'handle documents in the order they were opened
'reverse order of documents collection
'loop until second to last as last one is ThatDoc
Dim i As Long
Dim FileNames As String, fFound As Boolean
Dim fWritten As Boolean
For i = Application.Documents.Count To 2 Step -1
Set ThisDoc = Application.Documents(i)
'Don't check document where the code runs
If Not ThisDoc Is ThisDocument Then
Set r = ThisDoc.Range
With r
With .Find
.Text = ""
.Format = True
.Font.Bold = True
End With
Do While .Find.Execute(Forward:=True) = True
'<-- remove this part if not needed
'add filename if the first bold range
If fWritten = False Then
ThatDoc.Content.InsertAfter vbCrLf & vbCrLf & ThisDoc.Name & vbCrLf
End If
'remove this part if not needed -->
fWritten = True
'If r.HighlightColorIndex = wdDarkYellow Then 'highlightcols(7)
If r.Bold Then
ThatDoc.Range.Characters.Last.FormattedText = .FormattedText
ThatDoc.Range.InsertParagraphAfter
.Collapse 0
End If
Loop
End With
'add filename to list only if bold has been found
If fWritten = True Then
FileNames = FileNames & vbCrLf & ThisDoc.Name
fWritten = False
End If
End If
Next
'Add list of filenames to the end of ThatDoc
With ThatDoc.Content
.InsertParagraphAfter
.InsertAfter FileNames
End With
cleanUp:
Application.ScreenUpdating = True
Set ThatDoc = Nothing
Set ThisDoc = Nothing
End Sub
I am writing a vba macro for a word document. I use vba macro to generate textbox and text to the word document. The issue is that the textbox moves to the top of last page instead of staying on the first page.
I don't know what i am doing wrong. All i need is for that textbox to remain on the first page. I really need to include the textbox.
below is my code and the output image
Dim wrdDoc As Object
Dim tmpDoc As Object
Dim WDoc As String
Dim myDoc As String
myDoc = "myTest"
WDoc = ThisDocument.Path & "\mydocument.docx"
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then
' no current word application
Set wdApp = CreateObject("Word.application")
Set wrdDoc = wdApp.Documents.Open(WDoc)
wdApp.Visible = True
Else
' word app running
For Each tmpDoc In wdApp.Documents
If StrComp(tmpDoc.FullName, WDoc, vbTextCompare) = 0 Then
' this is your doc
Set wrdDoc = tmpDoc
Exit For
End If
Next
If wrdDoc Is Nothing Then
' not open
Set wrdDoc = wdApp.Documents.Open(WDoc)
End If
End If
ActiveDocument.Content.Select
Selection.Delete
With wdApp
.Visible = True
.Activate
With .Selection
Dim objShape As Word.Shape
Set objShape2 = ActiveDocument.Shapes.addTextbox _
(Orientation:=msoTextOrientationHorizontal, _
Left:=400, Top:=100, Width:=250, Height:=60)
With objShape2
.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.Left = wdShapeRight
.Top = wdShapeTop
.TextFrame.TextRange = "This is nice and shine" & vbCrLf & "222"
.TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
End With
With .Selection
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
For i = 1 To 40
.TypeText i
.TypeParagraph
Next i
End With
End With
Word Shape objects must be anchored to a character position in the Word document. They will always appear on the page where the anchor character is and, if the anchor formatting is not to the page, they will move relatively on the page with the anchor character.
A special case ensues when a document is "empty" (a lone paragraph), so it helps to make sure the document has more than one character in it. In the code sample below an additional paragraph is inserted before adding the TextBox - to the first paragraph.
I've made some other adjustments to the code:
Added On Error GoTo 0 so that error messages will appear. Otherwise, debugging becomes impossible.
Removed the With for the Word application since it's not necessary when using Word objects
Declared and use a Word Range object for inserting content. As with Excel, it's better to not work with Selection whenever possible.
Used the wrdDoc object you declare and instantiate instead of ActiveDocument.
This code worked fine in my test, but I cannot, of course, repro your entire environment.
Dim wrdDoc As Object
Dim tmpDoc As Object
Dim WDoc As String
Dim myDoc As String
myDoc = "myTest"
WDoc = ThisDocument.Path & "\mydocument.docx"
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
On Error GoTo 0
If wdApp Is Nothing Then
' no current word application
Set wdApp = CreateObject("Word.application")
Set wrdDoc = wdApp.Documents.Open(WDoc)
wdApp.Visible = True
Else
' word app running
For Each tmpDoc In wdApp.Documents
If StrComp(tmpDoc.FullName, WDoc, vbTextCompare) = 0 Then
' this is your doc
Set wrdDoc = tmpDoc
Exit For
End If
Next
If wrdDoc Is Nothing Then
' not open
Set wrdDoc = wdApp.Documents.Open(WDoc)
End If
End If
wdApp.Visible = True
wrdApp.Activate
Dim i As Long
Dim objShape2 As Word.Shape
Dim rng As Word.Range
Set rng = wrdDoc.Content
rng.Delete
With rng
.InsertAfter vbCr
.Collapse wdCollapseStart
Set objShape2 = ActiveDocument.Shapes.AddTextbox _
(Orientation:=msoTextOrientationHorizontal, _
Left:=400, Top:=100, Width:=250, Height:=60, Anchor:=rng)
With objShape2
.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.Left = wdShapeRight
.Top = wdShapeTop
.TextFrame.TextRange = "This is nice and shine" & vbCrLf & "222"
.TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
rng.Start = ActiveDocument.Content.End
For i = 1 To 40
.Text = i & vbCr
.Collapse wdCollapseEnd
Next i
End With
Another solution for you to look at.
'12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789
'========1=========2=========3=========4=========5=========6=========7=========8=========9=========A=========B=========C
Option Explicit
Sub textboxtest()
Const my_doc_name As String = "mydocument.docx"
Dim my_fso As Scripting.FileSystemObject
Dim my_doc As Word.Document
Dim my_range As Word.Range
Dim counter As Long
Dim my_text_box As Word.Shape
Dim my_shape_range As Word.ShapeRange
' There is no need to test for the Word app existing
' if this macro is in a Word template or Document
' because to run the macro Word MUST be loaded
Set my_fso = New Scripting.FileSystemObject
If my_fso.FileExists(ThisDocument.Path & "\" & my_doc_name) Then
Set my_doc = Documents.Open(ThisDocument.Path & "\" & my_doc_name)
Else
Set my_doc = Documents.Add
my_doc.SaveAs2 ThisDocument.Path & "\" & my_doc_name
End If
my_doc.Activate ' Although it should already be visible
my_doc.content.Delete
Set my_text_box = my_doc.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
left:=400, _
top:=100, _
Width:=250, _
Height:=60)
With my_text_box
.Name = "TextBox1"
.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.left = wdShapeRight
.top = wdShapeTop
With .TextFrame
.TextRange = "This is nice and shine" & vbCrLf & "222"
.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
End With
Set my_range = my_text_box.Parent.Paragraphs(1).Range
'FROM
'
' https://learn.microsoft.com/en-us/office/vba/api/word.shape'
' Every Shape object is anchored to a range of text. A shape is anchored
' to the beginning of the first paragraph that contains the anchoring
' range. The shape will always remain on the same page as its anchor.
my_range.Collapse Direction:=wdCollapseEnd
With my_range
For counter = 1 To 90
.Text = counter
.InsertParagraphAfter
.Collapse Direction:=wdCollapseEnd
Next
End With
End Sub
I want to insert the Excel file at the seartain BOOkmark in the Word doc without opening Excel, automatically inserted when the Word doc opens.
1.I'm thinking to make a pop up window with a open file dialog bottom firstly. And my code is following:(but it only work in excel VBA doesn't work in word VBA how should I change the code so that I can do it in word??? )
Sub openfile()
Dim intChoice As Integer
Dim strPath As String
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intChoice = Application.FileDialog(msoFileDialogOpen).Show
If intChoice <> 0 Then
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
End If
End Sub
Then I made a copy and paste bottom the code is as follows:(It also only work when l code it in excel how to change to word vba?)
Sub CopyWorksheetsToWord()
Dim wdApp As Word.Application, wdDoc As Word.Document, ws As Worksheet
Application.ScreenUpdating = False
Application.StatusBar = "Creating new document..."
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Add
For Each ws In ActiveWorkbook.Worksheets
ws.UsedRange.Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.Paste
Application.CutCopyMode = False
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
If Not ws.Name = Worksheets(Worksheets.Count).Name Then
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.InsertParagraphBefore
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdPageBreak
End With
End If
Next ws
Set ws = Nothing
Application.StatusBar = "Cleaning up..."
With wdApp.ActiveWindow
If .View.SplitSpecial = wdPaneNone Then
.ActivePane.View.Type = wdNormalView
Else
.View.Type = wdNormalView
End If
End With
Set wdDoc = Nothing
wdApp.Visible = True
Set wdApp = Nothing
Application.StatusBar = False
End Sub
This should get you started. Place the code below in your Word document in the 'ThisDocument' module.
Add Excel reference to your Word VBA. In the VBA editor go to Tools and then References. Check the box next to Microsoft Excel 14.0 Object Library.
Private Sub Document_Open()
Dim intChoice As Integer
Dim strPath As String
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intChoice = Application.FileDialog(msoFileDialogOpen).Show
If intChoice <> 0 Then
strPath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
End If
CopyWorksheetsToWord (strPath)
End Sub
Function CopyWorksheetsToWord(filePath As String)
Dim exApp As Excel.Application
Dim exWbk As Excel.Workbook
Dim exWks As Excel.Worksheet
Dim wdDoc As Word.Document
Application.ScreenUpdating = False
Application.StatusBar = "Creating new document..."
Set wdDoc = ActiveDocument
Set exApp = New Excel.Application
exApp.Visible = False
Set exWbk = exApp.Workbooks.Open(filePath)
For Each exWks In exWbk.Worksheets
exWks.UsedRange.Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.Paste
exApp.CutCopyMode = False
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
If Not exWks.Name = exWbk.Worksheets(exWbk.Worksheets.Count).Name Then
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.InsertParagraphBefore
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdPageBreak
End With
End If
Next exWks
Application.StatusBar = "Cleaning up..."
Set exWks = Nothing
exWbk.Close
Set exWbk = Nothing
Set exApp = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
End Function
Save file as macro-enabled file (.docm)
Close word file
Open word file and the code will run. First thing you'll see is a file open box to select the Excel file.
Tested code but there is no error checking.
Update per comment
Bookmarks can be located by name using the following syntax: wdDoc.Bookmarks("Bookmark2").Range
In this case I inserted a bookmark and labeled it Bookmark2
Updated Function Code:
Function CopyWorksheetsToWord(filePath As String)
Dim exApp As Excel.Application
Dim exWbk As Excel.Workbook
Dim exWks As Excel.Worksheet
Dim wdDoc As Word.Document
Dim bmRange As Range
Application.ScreenUpdating = False
Application.StatusBar = "Creating new document..."
Set wdDoc = ActiveDocument
Set exApp = New Excel.Application
exApp.Visible = False
Set exWbk = exApp.Workbooks.Open(filePath)
For Each exWks In exWbk.Worksheets
exWks.UsedRange.Copy
Set bmRange = wdDoc.Bookmarks("Bookmark2").Range
bmRange.Paste
exApp.CutCopyMode = False
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
If Not exWks.Name = exWbk.Worksheets(exWbk.Worksheets.Count).Name Then
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.InsertParagraphBefore
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdPageBreak
End With
End If
Next exWks
Application.StatusBar = "Cleaning up..."
Set exWks = Nothing
exWbk.Close
Set exWbk = Nothing
Set exApp = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
End Function
Since your looping through sheets you'll probably need to play with formatting and how your stacking each section in the document but this should get you going.
I'm playing around with this code snippet, which I found on SO.
Sub Test()
Dim objWord As Object
Dim ws As Worksheet
Set ws1 = ThisWorkbook.Sheets("Contact Information1")
Set ws2 = ThisWorkbook.Sheets("Contact Information2")
'Set ws3 = ThisWorkbook.Sheets("Contact Information3")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open "C:\Users\rshuell001\Desktop\Final Report.docx" ' change as required
With objWord.ActiveDocument
.Bookmarks("BkMark1").Range.Text = ws1.Range("A1:F24").Value
.Bookmarks("BkMark2").Range.Text = ws2.Range("A1:F8").Value
'.Bookmarks("Report3").Range.Text = ws3.Range("A1:F80").Value
End With
Set objWord = Nothing
End Sub
When I look at it, it makes sense. When I run the script, I get an error on this line:
.Bookmarks("BkMark1").Range.Text = ws1.Range("A1:F24").Value
The error message is:
Run-type error 13
Type mismatch
1) I'm not sure '.Bookmarks("BkMark1").Range.Text' will do what I want. I think it's more of a standard copy/paste.
2) I want to make sure the table fits in the Word document, so I'm going to need something like the line below, to get it to do what I want.
wd.Tables(1).AutoFitBehavior wdAutoFitWindow
Any ideas on how to make this work?
Thanks!
I came up with the script below. It does what I want.
Sub Export_Table_Word()
'Name of the existing Word doc.
'Const stWordReport As String = "Final Report.docx"
'Word objects.
Dim WDApp As Word.Application
Dim WDDoc As Word.Document
Dim wdbmRange1 As Word.Range
'Excel objects.
Dim wbBook As Workbook
Dim wsSheet1 As Worksheet
Dim rnReport1 As Range
'Initialize the Excel objects.
Set wbBook = ThisWorkbook
Set WDApp = New Word.Application
'Set wdDoc = wdApp.Documents.Open(wbBook.Path & "\" & stWordReport)
Set WDDoc = WDApp.Documents.Open("C:\Users\rshuell001\Desktop\Final Report.docx")
'Delete old fields and prepare to replace with new
Dim doc As Document
Dim fld As Field
Set doc = WDDoc
For Each fld In doc.Fields
fld.Select
If fld.Type = 88 Then
fld.Delete
End If
Next
Set wsSheet = wbBook.Worksheets("Contact Information1")
Set rnReport = wsSheet.Range("BkMark1")
Set wdbmRange = WDDoc.Bookmarks("BkMark1").Range
'Turn off screen updating.
Application.ScreenUpdating = False
'Copy the report to the clipboard.
rnReport.Copy
'Select the range defined by the "Report" bookmark and paste in the report from clipboard.
With wdbmRange
.Select
.Paste
End With
WDDoc.Tables(1).AutoFitBehavior wdAutoFitWindow
Set wsSheet = wbBook.Worksheets("Contact Information2")
Set rnReport = wsSheet.Range("BkMark2")
Set wdbmRange = WDDoc.Bookmarks("BkMark2").Range
Application.ScreenUpdating = False
rnReport.Copy
With wdbmRange
.Select
.Paste
End With
WDDoc.Tables(2).AutoFitBehavior wdAutoFitWindow
Set wsSheet = wbBook.Worksheets("Contact Information3")
Set rnReport = wsSheet.Range("BkMark3")
Set wdbmRange = WDDoc.Bookmarks("BkMark3").Range
Application.ScreenUpdating = False
rnReport.Copy
With wdbmRange
.Select
.Paste
End With
WDDoc.Tables(3).AutoFitBehavior wdAutoFitWindow
'Save and close the Word doc.
With WDDoc
.Save
.Close
End With
'Quit Word.
WDApp.Quit
'Null out your variables.
Set fld = Nothing
Set doc = Nothing
Set wdbmRange = Nothing
Set WDDoc = Nothing
Set WDApp = Nothing
'Clear out the clipboard, and turn screen updating back on.
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
MsgBox "The report has successfully been " & vbNewLine & _
"transferred to " & stWordReport, vbInformation
End Sub
I have a workbook full of worksheets I'm trying to copy and paste the contents of into a word document. Right now the code loops through all the worksheets and pastes them into a word document, but on top of each other. I had to change wdDoc.Range(wdDoc.Characters.Count - 1).Paste to wdDoc.Range(wdDoc.Characters.Count - 1).PasteExcelTable False, False, False and I'm not sure if this is the source of the problem; it does seem like a new page is being created, but the contents of the next worksheet just aren't being pasted into it. I'm not getting any error messages. Any advice would be appreciated!
Sub toWord()
Dim ws As Worksheet
Dim fromWB As Variant
Dim wdApp As Object
Dim wdDoc As Object
Dim docName As Variant
Dim rng As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add
wdDoc.Activate
'Creates InputBox that allows user to enter name to save document as
docName = Application.InputBox(Prompt:="Enter Document Name", Title:="Save Word Document", Type:=2)
wdDoc.SaveAs2 fileName:=docName, FileFormat:=wdFormatDocument 'Saves document under user-provided name
fromWB = Application.GetOpenFilename(FileFilter:="Excel Workbook(*.xlsx),*.xlsx", Title:="Open Merged Data")
If fromWB <> False Then
Set fromWB = Workbooks.Open(fromWB)
ElseIf fromWB = False Then
MsgBox "No File Selected"
GoTo ResetSettings
End If
For Each ws In fromWB.Worksheets
ws.Activate
ws.Range("A1:A2").Select
Selection.Copy
Set wdApp = GetObject(, "Word.Application")
wdApp.Visible = True
wdDoc.Activate
wdDoc.Range.Paste
ws.Activate
If ws.Range("A3").Value <> "" Then
Range("A2").CurrentRegion.Offset(2).Resize(Range("A2").CurrentRegion.Rows.Count - 2).Select
Selection.Columns.AutoFit
Selection.Copy
Set wdApp = GetObject(, "Word.Application")
wdApp.Visible = True
wdDoc.Activate
wdApp.Selection.EndKey Unit:=wdStory
wdApp.Selection.MoveDown Unit:=wdLine, Count:=1
wdApp.Selection.TypeParagraph
wdDoc.Range(wdDoc.Characters.Count - 1).PasteExcelTable False, False, False
wdApp.Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
wdDoc.Range.Collapse Direction:=0
wdDoc.Range(wdDoc.Characters.Count - 1).InsertBreak Type:=7
End If
Next ws
wdDoc.Styles("Normal").NoSpaceBetweenParagraphsOfSameStyle = True
wdDoc.Save
Set wdDoc = Nothing
Set wdApp = Nothing
Set fromWB = Nothing
MsgBox "Imported into Word Document"
ResetSettings:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Placeholder edit while testing:
Sub asdf()
Dim ws As Worksheet
Const wdStory = 6
Const wdMove = 0
For Each ws In ThisWorkbook.Worksheets
ws.Range("A7").Copy
Set docApp = GetObject(, "Word.Application")
Set doc = docApp.Documents.Open("PATH OF FILE")
docApp.Selection.EndKey wdStory
docApp.Selection.PasteAndFormat wdPasteDefault
Next ws
End Sub
Here's the code I got to work:
Sub toWord()
Dim ws As Worksheet
Dim fromWB As Variant
Dim wdApp As Object
Dim wdDoc As Object
Dim docName As Variant
Dim rng As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add
wdDoc.Activate
'Creates InputBox that allows user to enter name to save document as
docName = Application.InputBox(Prompt:="Enter Document Name", Title:="Save Word Document", Type:=2)
wdDoc.SaveAs2 fileName:=docName, FileFormat:=wdFormatDocument 'Saves document under user-provided name
fromWB = Application.GetOpenFilename(FileFilter:="Excel Workbook(*.xlsx),*.xlsx", Title:="Open Merged Data")
If fromWB <> False Then
Set fromWB = Workbooks.Open(fromWB)
ElseIf fromWB = False Then
MsgBox "No File Selected"
GoTo ResetSettings
End If
For Each ws In fromWB.Worksheets
ws.Activate
ws.Range("A1:A2").Select
Selection.Copy
Set wdApp = GetObject(, "Word.Application")
wdApp.Visible = True
wdDoc.Activate
wdDoc.Range(wdDoc.Characters.Count - 1).Paste
ws.Activate
If ws.Range("A4").Value <> "" Then
Application.Intersect(ws.UsedRange, ws.Cells.Resize(ws.Rows.Count - 2).Offset(2)).Select
Selection.Columns.AutoFit
Selection.Copy
Set wdApp = GetObject(, "Word.Application")
wdApp.Visible = True
wdDoc.Activate
wdApp.Selection.EndKey Unit:=wdStory
wdApp.Selection.MoveDown Unit:=wdLine, Count:=1
wdApp.Selection.TypeParagraph
wdDoc.Range(wdDoc.Characters.Count - 1).PasteExcelTable False, False, False
wdApp.Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
wdApp.Selection.Collapse Direction:=0
wdDoc.Range(wdDoc.Characters.Count - 1).InsertBreak Type:=7
Else
wdDoc.Range(wdDoc.Characters.Count - 1).InsertBreak Type:=7
End If
Next ws
wdDoc.Styles("No Spacing").NoSpaceBetweenParagraphsOfSameStyle = True
wdDoc.Save
Set wdDoc = Nothing
Set wdApp = Nothing
Set fromWB = Nothing
MsgBox "Imported into Word Document"
ResetSettings:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub