My code runs takes a word template that has bookmarks at key points (mostly blank placeholder tables) creates a new copy of that template and transfers the filled in version of those tables from excel at those bookmarks. At this point it is supposed to delete the previously blank table that originally resided in that word document.
Option Explicit
Sub TrialFive()
' Pop-up to inform user
MsgBox ("Please Select the CF Word Template")
' Declare variables for Word and Excel
Dim WordApp As Object, WordDoc As Object, path As String
Dim dlgSaveAs As FileDialog, fileSaveName As Variant
Dim ExcelWorksheet As Worksheet
Dim Table As ListObject
Dim BookmarkName As String
Dim TableData As Range
Dim i As Integer
Dim TableBookmarkMapping As Object
Dim SheetName As String
' Allows CF Template to be opened
With Application.FileDialog(msoFileDialogOpen)
.Show
If .SelectedItems.Count = 1 Then
path = .SelectedItems(1)
End If
End With
If path = "" Then
Exit Sub
End If
' Set Word application and open the selected document
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Open(path)
WordApp.Visible = True
' Pop-up to inform user about saving the document
MsgBox ("Select the location for where the CF Document should be saved and name it for the Site")
' Allows CF Template to be saved under a different file location and name
fileSaveName = Application.GetSaveAsFilename( _
fileFilter:="Word Documents (*.docx), *.docx")
WordApp.ActiveDocument.SaveAs2 Filename:=fileSaveName, _
FileFormat:=wdFormatDocumentDefault
' Copy Site Name from Excel to Word
ThisWorkbook.Sheets(1).Range("A6").Copy
If WordDoc.Bookmarks.Exists("Site_Name") Then
WordDoc.Bookmarks("Site_Name").Range.PasteAndFormat (wdFormatPlainText)
End If
' Manual mapping between Excel table names, sheet names, and Word bookmark names
Set TableBookmarkMapping = CreateObject("Scripting.Dictionary")
' Define the mapping: Excel Table Name -> Excel Sheet Name -> Word Bookmark Name
TableBookmarkMapping.Add "Building_List", Array("2 - Overview", "Building_List") ' Building_List (Sheet3) -> Table1
...
...
...
' Declare the Key variable
Dim Key As Variant
' Loop through each Excel Table (ListObject) and replace them in Word
For Each Key In TableBookmarkMapping.Keys
' Get the corresponding sheet name and bookmark name from the mapping
SheetName = TableBookmarkMapping(Key)(0)
BookmarkName = TableBookmarkMapping(Key)(1)
' Set the reference to the correct worksheet
Set ExcelWorksheet = ThisWorkbook.Sheets(SheetName)
' Get the corresponding Excel table (ListObject)
On Error Resume Next
Set Table = ExcelWorksheet.ListObjects(Key)
On Error GoTo 0
' Check if the table exists in the specified sheet
If Not Table Is Nothing Then
' Check if the bookmark exists in Word
If WordDoc.Bookmarks.Exists(BookmarkName) Then
' Place the cursor at the bookmark location
WordDoc.Bookmarks(BookmarkName).Range.Select
' Copy the Excel table data
Set TableData = Table.Range
TableData.Copy
' Paste the table at the bookmark location in Word
WordDoc.Bookmarks(BookmarkName).Range.Paste
' Format the pasted table
WordDoc.Tables(1).AutoFitBehavior (wdAutoFitWindow)
' After the new table is pasted, delete the table at the bookmark (if any)
If WordDoc.Bookmarks(BookmarkName).Range.Tables.Count > 1 Then
' If there is already a table at the bookmark (besides the one just pasted)
WordDoc.Bookmarks(BookmarkName).Range.Tables(1).Delete
End If
' Now delete the bookmark itself
WordDoc.Bookmarks(BookmarkName).Delete
End If
End If
Next Key
' Cleanup
Set TableBookmarkMapping = Nothing
Set WordDoc = Nothing
Set WordApp = Nothing
Set ExcelWorksheet = Nothing
End Sub
I'm using manual mapping so any additional data can be added by simply referencing it at that point and will be included in the iterations of the For loop(s). More Mapping arrays exist but have been redacted to make this easier to follow. Approximate count of total array is over 100 across multiple Excel sheets.
The part of the code that seems to be having the issue is the following loop which checks for the presence of tables at the bookmarks and should delete the second one, but nothing is deleted.
If WordDoc.Bookmakr(BookmarkName).Range.Tables.Count > 1 Then
WordDoc.Bookmarks(BookmarkName).Range.Tables(1).Delete
My code runs takes a word template that has bookmarks at key points (mostly blank placeholder tables) creates a new copy of that template and transfers the filled in version of those tables from excel at those bookmarks. At this point it is supposed to delete the previously blank table that originally resided in that word document.
Option Explicit
Sub TrialFive()
' Pop-up to inform user
MsgBox ("Please Select the CF Word Template")
' Declare variables for Word and Excel
Dim WordApp As Object, WordDoc As Object, path As String
Dim dlgSaveAs As FileDialog, fileSaveName As Variant
Dim ExcelWorksheet As Worksheet
Dim Table As ListObject
Dim BookmarkName As String
Dim TableData As Range
Dim i As Integer
Dim TableBookmarkMapping As Object
Dim SheetName As String
' Allows CF Template to be opened
With Application.FileDialog(msoFileDialogOpen)
.Show
If .SelectedItems.Count = 1 Then
path = .SelectedItems(1)
End If
End With
If path = "" Then
Exit Sub
End If
' Set Word application and open the selected document
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Open(path)
WordApp.Visible = True
' Pop-up to inform user about saving the document
MsgBox ("Select the location for where the CF Document should be saved and name it for the Site")
' Allows CF Template to be saved under a different file location and name
fileSaveName = Application.GetSaveAsFilename( _
fileFilter:="Word Documents (*.docx), *.docx")
WordApp.ActiveDocument.SaveAs2 Filename:=fileSaveName, _
FileFormat:=wdFormatDocumentDefault
' Copy Site Name from Excel to Word
ThisWorkbook.Sheets(1).Range("A6").Copy
If WordDoc.Bookmarks.Exists("Site_Name") Then
WordDoc.Bookmarks("Site_Name").Range.PasteAndFormat (wdFormatPlainText)
End If
' Manual mapping between Excel table names, sheet names, and Word bookmark names
Set TableBookmarkMapping = CreateObject("Scripting.Dictionary")
' Define the mapping: Excel Table Name -> Excel Sheet Name -> Word Bookmark Name
TableBookmarkMapping.Add "Building_List", Array("2 - Overview", "Building_List") ' Building_List (Sheet3) -> Table1
...
...
...
' Declare the Key variable
Dim Key As Variant
' Loop through each Excel Table (ListObject) and replace them in Word
For Each Key In TableBookmarkMapping.Keys
' Get the corresponding sheet name and bookmark name from the mapping
SheetName = TableBookmarkMapping(Key)(0)
BookmarkName = TableBookmarkMapping(Key)(1)
' Set the reference to the correct worksheet
Set ExcelWorksheet = ThisWorkbook.Sheets(SheetName)
' Get the corresponding Excel table (ListObject)
On Error Resume Next
Set Table = ExcelWorksheet.ListObjects(Key)
On Error GoTo 0
' Check if the table exists in the specified sheet
If Not Table Is Nothing Then
' Check if the bookmark exists in Word
If WordDoc.Bookmarks.Exists(BookmarkName) Then
' Place the cursor at the bookmark location
WordDoc.Bookmarks(BookmarkName).Range.Select
' Copy the Excel table data
Set TableData = Table.Range
TableData.Copy
' Paste the table at the bookmark location in Word
WordDoc.Bookmarks(BookmarkName).Range.Paste
' Format the pasted table
WordDoc.Tables(1).AutoFitBehavior (wdAutoFitWindow)
' After the new table is pasted, delete the table at the bookmark (if any)
If WordDoc.Bookmarks(BookmarkName).Range.Tables.Count > 1 Then
' If there is already a table at the bookmark (besides the one just pasted)
WordDoc.Bookmarks(BookmarkName).Range.Tables(1).Delete
End If
' Now delete the bookmark itself
WordDoc.Bookmarks(BookmarkName).Delete
End If
End If
Next Key
' Cleanup
Set TableBookmarkMapping = Nothing
Set WordDoc = Nothing
Set WordApp = Nothing
Set ExcelWorksheet = Nothing
End Sub
I'm using manual mapping so any additional data can be added by simply referencing it at that point and will be included in the iterations of the For loop(s). More Mapping arrays exist but have been redacted to make this easier to follow. Approximate count of total array is over 100 across multiple Excel sheets.
The part of the code that seems to be having the issue is the following loop which checks for the presence of tables at the bookmarks and should delete the second one, but nothing is deleted.
If WordDoc.Bookmakr(BookmarkName).Range.Tables.Count > 1 Then
WordDoc.Bookmarks(BookmarkName).Range.Tables(1).Delete
2 Answers
Reset to default 0This worked for me - just an example code
Sub Tester()
Dim wdApp As Object, doc As Object, bm As Object
'For testing, using an open instance of Word with one document loaded
' document has a bookmark "Tester" containing a placeholder table
Set wdApp = GetObject(, "word.Application")
Set doc = wdApp.ActiveDocument
If doc.Bookmarks.Exists("Tester") Then
Set bm = doc.Bookmarks("Tester")
ActiveSheet.ListObjects(1).Range.Copy 'copy a table...
bm.Range.Paste 'Pastes the copied table in front of the placeholder table
' and *outside of the bookmark*...
bm.Range.Tables(1).Delete 'removes the placeholder table
End If
End Sub
For example:
With WordDoc
If .Bookmarks.Exists(BookmarkName) Then
Table.Range.Copy
With .Bookmarks(BookmarkName).Range
If .Tables.Count = 1 Then .Tables(1).Delete
.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=True
.Bookmarks.Add Name:=BookmarkName, Range:=.Tables(1).Range
End With
End If
End With
The new table even retains the original bookmark. If you don't want that, simply comment-out or omit:
.Bookmarks.Add Name:=BookmarkName, Range:=.Tables(1).Range
Set Table = ExcelWorksheet.ListObjects(Key)only succeeds if there exists a listobject namedKey, but if it fails it does not clear the variableTable. If that line fails whenTablewas already set, you will not get the intended outcome. You shouldSet Table = Nothingright before thatOn Error Resume Next– Tim Williams Commented Feb 3 at 20:25