I am working on Macro that copies data from NamedCells in Excel and places them at specific Bookmarks in a Word template. I am getting a run time error 9 when the code gets to the pasting data at Bookmarks line. Further, some of the data is getting pasted into the template but "Title1" is getting pasted at BookmarkTitle2 location and Title2 is getting pasted at BookmarkTitle3... then the run time error comes up...
Code is below....
Can someone tell me what I am doing wrong?
Sub CopyExcelTitlesToWord()
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Dim BookmarkArray As Variant
Dim Title(1 To 3) As Range
Dim x As Integer
'List the tables/charts from excel you want to Word
Set Title(1) = ThisWorkbook.Worksheets("TopPage").Range("Title1")
Set Title(2) = ThisWorkbook.Worksheets("TopPage").Range("Title2")
Set Title(3) = ThisWorkbook.Worksheets("TopPage").Range("Title3")
'List of corresponding Word Bookmarks to paste the tables/charts to in Word
BookmarkArray = Array("BookmarkTitle1", "BookmarkTitle2", "BookmarkTitle3")
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Open Word template
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
'Open existing template in Word
Set myDoc = WordApp.Documents.Open("C:\Users\xxx\Desktop\TemplateTest1.docx")
'Loop Through and Copy/Paste Multiple Excel NamedCells
For x = LBound(Title) To UBound(Title)
Title(x).Select
Selection.Copy
'Paste Title into MS Word (using inserted Bookmarks -> ctrl+shift+F5). 'Name the Bookmarks so they are in Series so they are easy to loop through.
myDoc.Bookmarks(BookmarkArray(x)).Range.PasteExcelTable False, False, True
Next x
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
BookmarkArray will be a 0 based array (0..2) - see Excel help on the Array function.
I suggest you change
Dim Title(1 To 3) As Range
to
Dim Title(0 To 2) As Range
and change the hard coded indexes accordingly.
Related
I'm new to VBA and I need to copy one cell (that contains Data) from excel to a specific (not from a template) word document. the full path of the specific file will be in a cell next to the targeted cell - offset(0,1). All of that obviously in a loop because I have a big list and a lot of files.
this is my code (the code is made of some part I picked up while searching) - but I get an
object error
Sub OpenWordFile()
Dim oWord As Object
Dim xRg As Object
Dim xCell As Range
Dim xVal As Range
Dim Workbook As Workbook
Dim FileName As Variant
'Word Object
Set oWord = CreateObject(Class:="Word.Application")
oWord.Visible = True
'Open Word Document (need to be multiple files in a loop)
'oWord.documents.Open FileName:="C:\Users\tamirre\Desktop\New folder\135-185844.doc" ' OPEN AN EXISTING FILE.
'Set oWord = Nothing
'Activating Excel to copy Cells
ThisWorkbook.Worksheets("Sheet1").Activate
Set xRg = Application.InputBox("Please select Cells to copy to word docs:", ActiveWindow.RangeSelection.Address, , , , , 8)
If xRg Is Nothing Then Exit Sub
For Each xCell In xRg
xVal = xCell.Value
Set FileName = xVal.Offset(0, 1) 'Cell Must Contain name and full path of the doc file
xVal.Copy
oWord.documents.Open FileName:="FileName"
Selection.EndKey Unit:=wdStory
Selection.TypeParagraph
Selection.PasteExcelTable True, False, False
Next
End Sub
InputBox returns a String, not an Object.
Change the Dim line to this:
Dim xRg As String
and change the InputBox lines to this:
xRg = InputBox("Please select Cells to copy to word docs:", "Range Selection", ActiveWindow.RangeSelection.Address)
If xRg ="" Then Exit Sub
Then if you want to turn it into a Range object:
Dim xRange As Object
Set xRange = Range(xRg)
However, I do not recommend doing what you are doing this way. There are too many chances the user will enter something invalid and you will get errors.
I am looking for a Macro to export the contents of every table in a Word document(s) and move this content to Excel. Along with pulling the contents of the tables however, I would like the titles of each of these tables to be exported as well. The Word document(s) are formatted in a table of contents style, with the "titles" of the tables being the headers of each section of the table of contents. Some of the sections in the table of contents have no table within the section, in which case, I would like the macro to move on from that section if there is no table within it. I am trying to have this Macro work for multiple Word documents in a single folder. The great news is that I already have a Macro currently working that does everything I asked above EXCEPT for pull the title of each table section. Below is the Macro I am currently using. Any help is greatly appreciated!!
Sub import_word_table_to_excel()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim fldpath
Dim fld, fil As Object
Dim appWord As Word.Application
Dim docWord As Word.Document
Dim tableWord As Word.Table
Dim sdoc As String
' use to choose the folder having word documents
Application.FileDialog(msoFileDialogFolderPicker).Title = "Choose Folder"
Application.FileDialog(msoFileDialogFolderPicker).Show
fldpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
Set fso = CreateObject("scripting.filesystemobject")
Set fld = fso.getfolder(fldpath)
Set appWord = New Word.Application
appWord.Visible = True
For Each fil In fld.Files
' browse word documents in a folder
If UCase(Right(fil.Path, 4)) = UCase(".doc") Or UCase(Right(fil.Path, 5)) = UCase(".docx") Then
Set docWord = appWord.Documents.Open(fil.Path)
For Each tableWord In docWord.Tables
' copy word tables
tableWord.Range.Copy
' paste it on sheet 1 of excel file
Sheets(1).Paste Destination:=Sheets(1).Range("A65356").End(xlUp).Offset(1, 0)
Next
docWord.Close
End If
Next fil
appWord.Quit
Sheets(1).Select
Set tableWord = Nothing
Set docWord = Nothing
Set appWord = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I currently have a working macro (modified code from TheSpreadsheetGuru) that copies from A1 to last used row in column H and pastes that data as a picture to a Microsoft Word document. It works great, but I have to run the macro more than 20 times (once for each sheet), and I have multiple reports I run each week with this same criteria. Is it possible to have this code iterate through all the worksheets from the active sheet (which would be the first sheet needed) through the end of the workbook? I could use the worksheet names (Linda is first, Victoria is last sheet) but the names change fairly often and more sheets are often added, and I don't want to have to change the code each time.
Sub PasteAsPicture()
Dim tbl As Excel.Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim lastrow As Long
Dim startcell As Range
Set startcell = Range("H4")
PicNme = ActiveSheet.name & ".docx"
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Copy Range from Excel
With ActiveSheet
lastrow = ActiveSheet.Cells(.Rows.Count, startcell.Row).End(xlUp).Row
Set tbl = ActiveSheet.Range("A1:H" & lastrow)
End With
'Create an Instance of MS Word
On Error Resume Next
'Is MS Word already opened?
Set WordApp = GetObject(class:="Word.Application")
'Clear the error between errors
Err.Clear
'If MS Word is not already open then open MS Word
If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
'Handle if the Word Application is not found
If Err.Number = 429 Then
MsgBox "Microsoft Word could not be found, aborting."
GoTo EndRoutine
End If
On Error GoTo 0
'Make MS Word Visible and Active
'WordApp.Visible = True
'WordApp.Activate
'Create a New Document
Set myDoc = WordApp.documents.Add
'Copy Excel Table Range
tbl.CopyPicture xlPrinter
'Paste Table into MS Word
With myDoc.PageSetup
.Orientation = wdOrientLandscape
.TopMargin = WordApp.InchesToPoints(1)
.BottomMargin = WordApp.InchesToPoints(1)
.LeftMargin = WordApp.InchesToPoints(0.5)
.RightMargin = WordApp.InchesToPoints(0.5)
End With
With myDoc
.Paragraphs(1).Range.Paste
.SaveAs Filename:="H:\QBIRT Reports\New Establishments\Reports\" & PicNme
.Close
End With
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
VBA uses the For Each... Next Statement to loop over arrays and collections. Using this method you can repeat the same action on every worksheet in the workbook.
' Calls PasteAsPicture, for each sheet in the workbook.
Sub ForEachWorksheet()
Dim ws As Worksheet
' Loop over every sheet in the book.
For Each ws In ThisWorkbook.Sheets
' Paste as picture requires the current sheet to be selected.
' You cannot activate hidden and very hidden sheets, without first unhiding.
If ws.Visible = xlSheetVisible Then
ws.Activate
PasteAsPicture
End If
Next
End Sub
If you want to start building up a library of VBA macros, that you can call from any workbook, research Excel's start up path and .xla file format.
I am trying to copy and paste multiple tables from excel to word but it's giving me Subscript out of range error when I am trying to define tbl. I found the codes online and is trying to modify the codes to suit my needs.
Sub ExcelTablesToWord_Modified()
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim sheet As Excel.Worksheet
Dim tableName As String
With dict
.Add "TableA1", "TableA1"
.Add "TableA2", "TableA2"
.Add "TableB1", "TableB1"
.Add "TableB2", "TableB2"
.Add "TableC", "TableC"
.Add "TableD", "TableD"
.Add "TableE1", "TableE1"
.Add "TableE2", "TableE2"
.Add "TableF1", "TableF1"
.Add "TableF2", "TableF2"
'TODO: add the remaining WorksheetName/TableName combinations
End With
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Set Variable Equal To Destination Word Document
On Error GoTo WordDocNotFound
Set WordApp = GetObject(class:="Word.Application")
WordApp.Visible = True
Set myDoc = WordApp.Documents("a.docx")
On Error GoTo 0
'Loop Through Worksheets, and Copy/Paste Multiple Excel Tables
For Each sheet In ActiveWorkbook.Worksheets
tableName = dict(sheet.Name)
'Copy Table Range from Excel
sheet.ListObjects(tableName).Range.Copy
'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
myDoc.Bookmarks(tableName).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit the most-recently-pasted Table so it fits inside Word Document
myDoc.Tables(myDoc.Tables.Count).AutoFitBehavior (wdAutoFitWindow)
Next sheet
'Completion Message
MsgBox "Copy/Pasting Complete!", vbInformation
GoTo EndRoutine
'ERROR HANDLER
WordDocNotFound:
MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16
'Put Stuff Back The Way It Was Found
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
Below will copy the first Table in every worksheet and paste into Word doc, regardless of the Table Name. The bookmark names in the Word doc assumed to be simply start at 1 with prefix "bookmark".
If specific Table names are really required, then create a Collection for the names, and loop through each Table in each Worksheet, if that table name is in the Collection then proceed to copy.
Option Base 1 'Force arrays to start at 1 instead of 0
Sub ExcelTablesToWord()
Dim oWS As Worksheet
Dim tbl As Excel.Range
Dim WordApp As Object ' Word.Application
Dim myDoc As Object ' Word.Document
Dim x As Long ' Integer
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Set Variable Equal To Destination Word Document
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If WordApp Is Nothing Then Set WordApp = CreateObject("Word.Application")
If WordApp Is Nothing Then GoTo WordDocNotFound
WordApp.Visible = True
Set myDoc = WordApp.Documents("a.docx")
If myDoc Is Nothing Then Set myDoc = WordApp.Documents.Open("a.docx")
If myDoc Is Nothing Then GoTo WordDocNotFound
'Loop Through and Copy/Paste Multiple Excel Tables
x = 1 ' For x = LBound(TableArray) To UBound(TableArray)
For Each oWS In ThisWorkbook.Worksheets
'Copy Table Range from Excel
'Set tbl = ThisWorkbook.Worksheets(x).ListObjects(TableArray(x)).Range
Set tbl = oWS.ListObjects(1).Range
If Not tbl Is Nothing Then
tbl.Copy
'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
myDoc.Bookmarks("bookmark" & x).Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
'Autofit Table so it fits inside Word Document
myDoc.Tables(x).AutoFitBehavior 2 ' (wdAutoFitWindow)
x = x + 1
End If
Next
On Error GoTo 0
'Completion Message
MsgBox "Copy/Pasting Complete!", vbInformation
GoTo EndRoutine
'ERROR HANDLER
WordDocNotFound:
MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16
'Put Stuff Back The Way It Was Found
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
The code I had originally provided was based on your original model, in which the corresponding Worksheet, Table, and Bookmark in each set had a different name.
Now that you have ensured that the names of the objects in each set are identical (which is a better model), try the following procedure. The only difference is that the Scripting.Dictionary has been eliminated, and the Worksheet name is being used to provide both the name of the Table and the name of the Bookmark (since all three values match now).
As before, this one has also been tested in Excel/Word 2016, and is functioning as expected:
Public Sub ExcelTablesToWord_Modified2()
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim sheet As Excel.Worksheet
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Set Variable Equal To Destination Word Document
On Error GoTo WordDocNotFound
Set WordApp = GetObject(class:="Word.Application")
WordApp.Visible = True
Set myDoc = WordApp.Documents("a.docx")
On Error GoTo 0
'Loop Through Worksheets, and Copy/Paste Multiple Excel Tables
For Each sheet In ActiveWorkbook.Worksheets
'Copy Table Range from Excel
sheet.ListObjects(sheet.Name).Range.Copy
'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
myDoc.Bookmarks(sheet.Name).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit the most-recently-pasted Table so it fits inside Word Document
myDoc.Tables(myDoc.Tables.Count).AutoFitBehavior (wdAutoFitWindow)
Next sheet
'Completion Message
MsgBox "Copy/Pasting Complete!", vbInformation
GoTo EndRoutine
'ERROR HANDLER
WordDocNotFound:
MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16
'Put Stuff Back The Way It Was Found
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
If you still receive the same error, then perhaps the Workbook is corrupted. In that case, try doing the following:
Create a new Workbook with one Worksheet
Rename the Worksheet so that its name matches the name of one of the Bookmarks in the Word document
Manually add a single, small, "testing-only" Table to the Worksheet (do not copy/paste one from the original Workbook)
Ensure that the Table's name is the same as the Worksheet's name
Copy/paste the above procedure into a new Module in that Workbook
Save the new Workbook
Ensure your Word document is open, and run the procedure
If that works, then you might consider recreating your entire original Workbook in the new Workbook. When doing so, if your datasets are large enough that you must copy/paste from the Original Workbook, use "Paste Special" with "Values Only" instead of just a normal Paste. Then, re-create any missing formatting manually. That way, it will be less likely that any corruption in the original Workbook will be transferred to the new one.
I am currently working on a project that have one word template embedded in one excel template.
A button in excel was created for opening the embedded word template, exporting the data from excel and puting them into word by using bookmarks in word template. The issue is that word report can be generated only once, because the text will be insert into the original bookmark rather than overwrite the previous data.
I'm trying to export a named field from excel(CoverPageRCA) and copy it into an embedded word template using a bookmark (bkmtable1_1).
I get:
run-time error 13 Type mismatch
that occurs at the following line:
Set bkMark = ActiveDocument.Bookmarks(bookmarkname).Range
I searched the web and spent almost 24 hrs on it. Can anybody please suggest a solution?
Option Explicit
Dim WD As New Word.Application
Dim RCAcell1 As Range
Sub CreateRCAReports1()
Dim wordDoc As Word.Document
Dim oleObj As oleObject
Dim WordApp As Word.Application
WD.Visible = True
Set oleObj = ActiveWorkbook.Sheets("CoverPageRCA").OLEObjects(1)
oleObj.Verb xlVerbPrimary
Set WordApp = oleObj.Object.Application
With WordApp
.Visible = True
.Activate
Set wordDoc = .Documents(1)
End With
'-------------------------------------------------------
ThisWorkbook.Sheets("CoverPageRCA").Activate
ActiveSheet.Range("B2").Select
Set RCAcell1 = ActiveSheet.Range(ActiveCell, ActiveCell.End(xlDown))
'go to each bookmark and type in details
CopyCell1 "bkmtable1_1", 1
Set WD = Nothing
End Sub
'----------------------------------------------------------
Sub CopyCell1(bookmarkname As String, RowOffset As Integer)
Dim bkMark As Range
'clear content on each bookmark and add new bookmarK
Set bkMark = ActiveDocument.Bookmarks(bookmarkname).Range
bkMark.Select
bkMark.Text = "dsfsf"
ActiveDocument.Bookmarks.Add bookmarkname, bkMark
'copy each cell to relevant Word bookmark
WD.Selection.GoTo What:=wdGoToBookmark, Name:=bookmarkname
WD.Selection.TypeText RCAcell1(RowOffset, 1).Value
End Sub
Looking at the code, the issue is on declaration of bkMark:
Dim bkMark As Range
The range object exists on both Excel and Word (different objects), and as the code above runs on excel, it will declare bkMark as an Excel Range object, not a Word Range object.
But the range returned on the line below is a Word range, causing the type mismatch error.:
Set bkMark = ActiveDocument.Bookmarks(bookmarkname).Range
To fix this issue, you must declare bkMark as a Word range,:
Dim bkMark As Word.Range