Copy and paste INCLUDING bookmarks VBA - vba

I have an Excel worksheet from which I am trying to paste Information into a wordfile "Template" (just a word-document in the layout I want), which contains bookmarks. What I would like to do is:
Copy everything in the word document (including bookmarks)
Replace the bookmarks with the data in my sheet
Go to the bottom of the page, insert a page break and paste the copied Text, including bookmarks
Loop through points 2 & 3 for all the rows in my excel file
I have patched together some code, but I'm unable to get the bookmark to paste the text with the bookmarks still intact. Can any of you help me get there?
Sub ReplaceBookmarks
'Select template
PickFolder = "C:\Users\Folder"
Set fdn = Application.FileDialog(msoFileDialogFilePicker)
With fdn
.AllowMultiSelect = False
.Title = "Please select the file containing the Template"
.Filters.Clear
.InitialFileName = PickFolder
If .Show = True Then
Temp = fdn.SelectedItems(1)
End If
End With
'open the word document
Set wdApp = CreateObject("Word.Application")
Set wdDoc = wdApp.Documents.Open(Temp)
'show the word document - put outside of loop for speed later
wdApp.Visible = True
'Copy everything in word document
wdDoc.Application.Selection.Wholestory
wdDoc.Application.Selection.Copy
LastRow2 = 110 ' In real code this is counted on the sheet
For i = 2 To LastRow2
'Data that will replace bookmarks in ws2 (defined somewhere in real code)
Rf1 = ws2.Cells(i, 4).Value
Rf2 = ws2.Cells(i, 2).Value
Rf3 = ws2.Cells(i, 3).Value
'replace the bookmarks with the variables - references sub "Fillbookmark"
FillBookmark wdDoc, Rf1, "Rf1"
FillBookmark wdDoc, Rf2, "Rf2"
FillBookmark wdDoc, Rf3, "Rf3"
' Jump to bottom of document, add page break and paste
With wdDoc
.Application.Selection.EndKey Unit:=wdStory
.Application.Selection.InsertBreak Type:=wdPageBreak
.Application.Selection.PasteAndFormat (wdFormatOriginalFormatting)
End With
Next i
End Sub
Sub FillBookmark(ByRef wdDoc As Object, _
ByVal vValue As Variant, _
ByVal sBmName As String, _
Optional sFormat As String)
Dim wdRng As Object
'store the bookmarks range
Set wdRng = wdDoc.Bookmarks(sBmName).Range
'if the optional format wasn’t supplied
If Len(sFormat) = 0 Then
'replace the bookmark text
wdRng.Text = vValue
Else
'replace the bookmark text with formatted text
wdRng.Text = Format(vValue, sFormat)
End If
End Sub

First try, instead of Copy/Paste, using WordOpenXml. This is much more reliable than copy/paste. Now remember that a Bookmark is a named location, when you copy a section of the document and put it back on another location when the original bookmark is still in place, the new section won't get the copied Bookmark.
I'll provide a little bit of code to show this to you:
Sub Test()
ActiveDocument.Bookmarks.Add Name:="BM1", Range:=ActiveDocument.Paragraphs(1).Range
ActiveDocument.Application.Selection.WholeStory
Dim openxml As String
openxml = ActiveDocument.Application.Selection.wordopenxml
ActiveDocument.Bookmarks(1).Delete
With ActiveDocument
.Application.Selection.EndKey Unit:=wdStory
.Application.Selection.InsertBreak Type:=wdPageBreak
.Application.Selection.InsertXML xml:=openxml
End With
' ActiveDocument.Bookmarks(1).Delete
With ActiveDocument
.Application.Selection.EndKey Unit:=wdStory
.Application.Selection.InsertBreak Type:=wdPageBreak
.Application.Selection.InsertXML xml:=openxml
End With
End Sub
Now open a new document enter some text by entering =Rand() as text in the document and hit enter
Next run the code from the Test macro.
You'll see that because you delete the bookmark using ActiveDocument.Bookmarks(1).Delete from the original part the first inserted text now contains the bookmark, the second does not.
If you uncomment the ' ActiveDocument.Bookmarks(1).Delete line you will see that the bookmark ends up in the second added text part because there is no duplicate bookmark anymore when creating the second section.
So in short, copying a bookmark will not duplicate the bookmark when pasting it, so you need to make sure you either delete the original bookmark or rename the bookmarks to make them unique again. Duplicates is a no go.

Related

InlineShapes.AddOLEObject without opening the MSWord UI

I am trying to use VBA to add an embedded OLE (Empty MSWord document, Icon:=True) from an open MSWord document without opening the User Interface for the newly created Empty MSWord document). The following VBA replaces the second paragraph in the current document with the MSWord OLE Icon, But it opens the MSWord Icon document in its own window.
Sub InsertOLEobject()
ActiveDocument.InlineShapes.AddOLEObject _
ClassType:="Word.Document", DisplayAsIcon:=True, _
Range:=ActiveDocument.Paragraphs(2).Range 'Replaces the second paragraph with the MSWord Icon
End Sub
Can anyone give me some advice?
The following is the latest VBA code to do what I wanted to do. The InlineShapes.AddOLEObject will not open the Word User Interface if you use an existing file. I was just hoping for a more elegant way without creating a file that needs to be deleted.
Sub InsertOLEobject()
Dim docNewBlank As Document
Set docNewBlank = Documents.Add
Set DocA = ActiveDocument
With docNewBlank
'Centering the paragraph within the blank document
.Paragraphs(1).Alignment = wdAlignParagraphCenter
'Saved the file to a temporary scratch location
.SaveAs FileName:="c:\temp\Blank.doc"
.Close 'Close the word document
End With
'Add the embedded MSWord OLE Icon
ActiveDocument.InlineShapes.AddOLEObject _
ClassType:="Word.Document", _
FileName:="c:\Temp\Blank.doc", _
DisplayAsIcon:=True, _
IconLabel:="Blank.doc", _
IconFileName:="WINWORD.EXE", _
Range:=ActiveDocument.Paragraphs(2).Range
'Set the filename of your choice
'Set the Range to the destination of the ole icon
'Set the icon to the path of your WINWORD.EXE
End Sub
FWIW I'm not sure I have followed exactly what you are trying to do, but I wonder whether this will do what you need (except the document isn't quite empty and will be a .docx rather than a .doc):
Sub embedNearlyEmptyWordDoc()
Dim appFullName As String
' Windows only, perhaps there is a better place to get this string
appFullName = Application.Path & Application.PathSeparator & "winword.exe"
With ActiveDocument
' insert a space somewhere "safe" (not necessarily where I have put it
.Range(0, 0).Text = " "
.Range(0, 1).Copy
.Range(0, 0).Text = ""
End With
' Alter this to put the doc where you want
ActiveDocument.Paragraphs(2).Range.PasteSpecial IconIndex:=0, Link:=False, Placement:=wdInLine, DisplayAsIcon:=True, DataType:=wdPasteOLEObject, IconFileName:=appFullName, IconLabel:="Blank.docx"
End Sub
The ultimate solution was to add "ActiveWindow.Close" after inserting the Word OLE Icon with a blank name; this closes the window just opened by the "ActiveDocument.InlineShapes.AddOLEObject". So I did not have to create a blank.doc first; so I deleted that VBA code.
I was asked what my goal was going into this project; my goal was to cut Tables and Images within a document and paste them in place into Word OLE objects icons. The resulting word file with all images and tables encapsulated into Word OLE object icons that can be used as an input to the Rational DOORS (DOORS) export Addin. I could have exported the images and tables in DOORS directly so they are viewable within DOORS but if you have ever double clicked on an image or table in DOORS you would find out that the OLE object opens within the cell and is very hard to edit, resize, or position. I separated the table function from the inlineshapes sub; my VBA code is as follows:
'================================================================================
' Cut all Tables and paste them into Word OLE Icons
'================================================================================
Sub IconizeInlineTables()
'================================================================================
Dim iTable As Table
Dim RngA As Range
Dim RngB As Range
Dim RngC As Range
Dim DocA As Document
Dim DocC As Document
Set DocA = ActiveDocument
For Each iTable In DocA.Tables
Set RngA = iTable.Range 'Go to the start of the table
RngA.Expand Unit:=wdTable
Set RngB = RngA.Duplicate 'Duplicate the range to keep track of table location
RngB.Collapse Direction:=wdCollapseEnd 'Collapse the Duplicate range to the point after the Table
RngA.Select
'MsgBox "Tables Left to Process =" & DocA.Tables.Count
Selection.Cut 'Cut the Table and put it in the paste buffer
'Insert the MSWord.doc OLE icon
ActiveDocument.InlineShapes.AddOLEObject _
ClassType:="Word.Document", _
FileName:="", _
LinkToFile:=False, _
DisplayAsIcon:=True, _
IconFileName:="WINWORD.EXE", _
IconLabel:="Table-" & iTableCount & ".doc", _
Range:=RngB
ActiveWindow.Close
'Expand the range to include the OLE icon then select the new range
With RngB
.Expand Unit:=wdParagraph
.Paragraphs(1).Style = wdStyleBodyText 'Apply the Body Text style
.Paragraphs(1).Format.Alignment = wdAlignParagraphCenter 'Center the paragraph
.InlineShapes(1).Select 'Select the inlineshape containing the OLE
End With
'Make sure that the InlineShape is the OLE icon
If InStr(1, RngB.InlineShapes(1).OLEFormat.ProgID, "Word.Document.", vbTextCompare) Then
Set DocC = RngB.InlineShapes(1).OLEFormat.Object 'Select the OLE Object
Set RngC = DocC.Paragraphs(1).Range 'Select the first Paragraph within the OLE Object
With RngC
.Paragraphs(1).Style = wdStyleBodyText 'Apply the Body Text style
.Paragraphs(1).Format.Alignment = wdAlignParagraphCenter 'Center the paragraph
.Collapse Direction:=wdCollapseEnd 'Collapse to just beyond end of paragraph
.MoveEnd Unit:=wdCharacter, Count:=-1 'Back the RngC up one character to not include the paragraph marker
.Select
.Paste 'Paste the Table cut with RngA.cut here
End With
Else 'Something I did not expect happened
MsgBox "Error: " & Selection.InlineShapes(1).OLEFormat.ProgID & "Not Expected"
End If
Next
End Sub
'================================================================================
' Cut all Figures and paste them into Word OLE Icons
'================================================================================
Sub IconizeInlineShapes()
'================================================================================
Dim iShape As InlineShape
Dim RngA As Range
Dim RngB As Range
Dim RngC As Range
Dim DocA As Document
Dim DocC As Document
Set DocA = ActiveDocument
Selection.GoTo What:=wdGoToSection, Which:=wdGoToFirst 'Start at the beginning of the document
For Each iShape In DocA.InlineShapes
If iShape.Type = wdInlineShapePicture Then
Set RngA = iShape.Range 'Set the range to the image
Set RngB = RngA.Duplicate 'Duplicate the range to keep track of location
RngB.Collapse Direction:=wdCollapseEnd 'Collapses to the end of the selection
RngA.Select
Selection.Cut 'Cut the image and put it in the paste buffer
'Insert the MSWord OLE icon
ActiveDocument.InlineShapes.AddOLEObject _
ClassType:="Word.Document", _
FileName:="", _
LinkToFile:=False, _
DisplayAsIcon:=True, _
IconFileName:="WINWORD.EXE", _
IconLabel:="Figure-" & DocA.InlineShapes.Count & ".doc", _
Range:=RngB
ActiveWindow.Close
'The inserted OLE is the next InlineShape to be found so you don't have to select it just loop around to next iShape
ElseIf InStr(1, iShape.OLEFormat.ProgID, "Word.Document.", vbTextCompare) Then 'Make sure iShape OLE object was next
Set DocC = iShape.OLEFormat.Object 'Select the OLE object
Set RngC = DocC.Paragraphs(1).Range 'Select the first Paragraph within the OLE Object
RngC.Paragraphs(1).Style = wdStyleBodyText 'Apply the Body Text style
RngC.Paragraphs(1).Format.Alignment = wdAlignParagraphCenter 'Center the paragraph
RngC.Collapse Direction:=wdCollapseEnd 'Collapse to just beyond end of paragraph
RngC.MoveEnd Unit:=wdCharacter, Count:=-1 'Back the RngC up one character to not include the paragraph marker
RngC.Select
RngC.Paste 'Paste the image cut with RngA.cut here
Else 'Something I did not expect happened
MsgBox "Warning: " & iShape.OLEFormat.ProgID & "Not handled by this software"
End If
Next
End Sub
Note the "IconFileName:="WINWORD.EXE" is generic but may have to be modified for your particular installation.

Use Word Macro/VBA to Copy Tables from One Word Document to Another Word Document

I am new to VBA and I would like seek help to create a Word macro to copy certain content tables from Microsoft Office 365 Word Document A to Microsoft Office 365 Word Document B.
Document A has at least 1 content table, but it can have up to, for example, 20 content tables. In order words, the upper bound is dynamic.
1.1 Each content table has two rows and four columns:
1.1.1 the first row has four column cells,
1.1.2 the second row has the first and second column cells merged into one cell, and thus the second row has three columns.
Document B is a blank template. It has some pre-defined text content and then followed by 20 blank content tables. The content table structure in Document B is the same as that in Document A.
The macro needs to do the following:
3.1 Copy the content tables from Document A to Document B in the same sequential order.
3.2 For each content table in Document A, copy as below:
3.2.1 Copy the first row as is to the first row of the corresponding content table in Document B.
3.2.2 Copy the second row as below:
3.2.2.1 Copy the second row’s first column/cell in Document A to the second row’s first column/cell in Document B.
3.2.2.2 Copy the second row’s third column/cell in Document A to the second row’s second column/cell in Document B. That’s all.
I tried to record a macro to do the above but it did not work.
Please kindly advise and help.
Your Document B, which you (probably erroneously) call a template is not blank - it has content. As for the table replication, try:
Sub Demo()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, t As Long
With Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)
.Title = "Select the source file"
.AllowMultiSelect = False
If .Show = -1 Then
Set DocSrc = Documents.Open(.SelectedItems(1), ReadOnly:=True, AddToRecentFiles:=False)
Else
MsgBox "No source file selected. Exiting", vbExclamation
GoTo ErrExit
End If
End With
With Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)
.Title = "Select the target file"
.AllowMultiSelect = False
If .Show = -1 Then
Set DocTgt = Documents.Open(.SelectedItems(1), ReadOnly:=False, AddToRecentFiles:=False)
Else
MsgBox "No target file selected. Exiting", vbExclamation
DocSrc.Close SaveChanges:=False
GoTo ErrExit
End If
End With
With DocSrc
For t = 1 To .Tables.Count
DocTgt.Tables(t).Range.FormattedText = .Tables(t).Range.FormattedText
DocTgt.Tables(t).Cell(2, 3).Range.Text = vbNullString
DocTgt.Tables(t).Cell(2, 4).Range.Text = vbNullString
Next
.Close False
End With
DocTgt.Activate
ErrExit:
Set DocSrc = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub

Word VBA: How to Fix FOR EACH loop to add bookmark to each sentence?

Within a Word docx: I'm trying to add a bookmark to each sentence. For example, at first sentence would be bookmark "bmarkpg01" and second sentence would be bookmark ""bmarkpg01ln01col01"". My code adds only one bookmark to first sentence and doesn't loop through to end of document.
I've tried a for each loop to attempt each sent in sentences and each bmark in bookmark.
Sub tryAddBmarkatSentence()
Dim myRange As Range
Set myRange = ActiveDocument.Content
Dim bmark As Bookmark
Application.ScreenUpdating = False
For Each MySent In ActiveDocument.Sentences
For Each bmark In ActiveDocument.Bookmarks
ActiveDocument.Bookmarks.Add Name:="pmark" & bmark.Range.Information(wdActiveEndAdjustedPageNumber), Range:=myRange 'bmark name would have added info of page, line, and col number. here as example is pagenumber.
Next
Next
End Sub
EXPECTED RESULT: Within entire document, each sentence has a corresponding bookmark and bookmark name ("bmarkpg01ln01col01", "bmarkpg01ln02col10", etc.)
ACTUAL RESULTS: only one bookmark is added to the first sentence of the document.
The following works for me, as far as the requirements in the question go.
Please remember to put Option Explicit at the top of a code page. This will force you to declare ("Dim") variables, but will also save time and trouble as it will prevent typos and warn you of other problems.
A Sentence in Word returns a Range object, so the code below delares MySent As Range. This provides the target Range for the Bookmarks.Add method.
If you won't be doing anything else with the bookmark, it's not strictly necessary to Set bkm = when adding the bookmark. I left it in since it is declared in the code in the question.
It's not necessary to loop the collection of bookmarks - espeicially since there aren't any - they're being added.
I've added some code for naming the bookmarks, as well.
Sub tryAddBmarkatSentence()
Dim doc As Word.Document
Dim MySent As Word.Range
Dim bmark As Bookmark
Application.ScreenUpdating = False
Set doc = ActiveDocument
For Each MySent In doc.Sentences
Set bmark = doc.Bookmarks.Add(Name:="bmark" & _
MySent.Information(wdActiveEndAdjustedPageNumber) & "_" &_
MySent.Information(wdFirstCharacterLineNumber) & "_" & _
MySent.Information(wdFirstCharacterColumnNumber), Range:=MySent)
'bmark name would have added info of page, line, and col number. here as example is pagenumber.
Next
End Sub
u can try like this
Sub tryAddBmarkatSentence()
Dim myRange As Range
Set myRange = ActiveDocument.Content
Dim bmark As Bookmark
Application.ScreenUpdating = False
For Each MySent In ActiveDocument.Sentences
ActiveDocument.Bookmarks.Add ... and the rest of the code.
//i dont know how you define witch bookmark is to asign to that sentence
Next
End Sub

Excel to Word VBA Export - Word Documents Not Being Created

I'm running an Excel to Word Export and I cannot create / save new documents based on the template. Each loop will reopen the word template, replaces the <<>> values in the template, and then moves on the next.
(Background - I have a table in Excel consisting 32 rows and 70 columns. I've created a corresponding word template consisting of values to replace from the excel sheet (for instance, <>). On the run, It exports values based on corresponding tags (for instance, <>) in the Excel sheet to the Word Doc). It seems to be working until it gets to WordDoc.SaveAs Filename
The error I get is
Do you want to save your document as the template name? yes / no
it stops there and does not create templates but only changes the template file.
Can anyone suggest a fix to this?
Sub CreateWordDoc()
Dim BenefitRow, BenefitCol, LastRow As Long
Dim TagName, TagValue, Filename As String
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim WordContent As Word.Range
On Error Resume Next
With Sheets("VBA Output")
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make visible
LastRow = .Range("A9999").End(xlUp).Row 'Determine last row
For BenefitRow = 4 To 6
Set WordDoc = WordApp.Documents.Open(Filename:=" template name.dotm", ReadOnly:=False) 'Open Template saved as .dotm
For BenefitCol = 1 To 79
TagName = .Cells(3, BenefitCol).Value 'Tag Name
TagValue = .Cells(BenefitRow, BenefitCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll ',Forward:True, Wrap:wdFindContinue
End With
Next BenefitCol
Filename = ThisWorkbookPath & "\" & .Range("E" & BenefitRow).Value & ".docx"
WordDoc.SaveAs Filename
WordDoc.Close
Next BenefitRow
End With
WordApp.Quit
End Sub
The problem (error message) you're seeing comes from opening a template file then wanting to save it as a "plain vanilla" document. This isn't how Word was designed to be used, which is why Word is basically saying, "Are you sure that's what you want to do?"
A template should not be opened unless the purpose is to change the template, itself. In that case, it would be saved again as a template - no message would be displayed.
When creating new documents from a template use the Documents.Add method:
Set WordDoc = WordApp.Documents.Add(Template:=" template name.dotm")
This automatically creates a copy of the template - there's no danger of overwriting the template. And the message mentioned in the question will not appear when the SaveAs method is executed.

How to extract / delete first word of each page?

I did a mailmerge to create dynamic word pages with customer information.
Then I did (by looking on the net) a macro to split the result file into several pages, each page being saved as one file.
Now I'm looking to give those files some names containing customer info. I googled that and I think the (only?) way is to create a mergefield with that info, at the very beginning of the page, then extract and delete it from the page with a macro to put it in file names.
Example: If I have a customer named Stackoverflow I would like to have a file named Facture_Stackoverflow.doc.
I found nowhere how to select, extract and then delete this first word from my page.
Here is my "splitting macro", which currently names the files just with an incremented ID:
Sub DecouperDocument()
Application.Browser.Target = wdBrowsePage
For i = 1 To ActiveDocument.BuiltInDocumentProperties("Number of Pages")
ActiveDocument.Bookmarks("\page").Range.Copy
Documents.Add
Selection.Paste
Selection.TypeBackspace
ChangeFileOpenDirectory "C:\test\"
DocNum = DocNum + 1
ActiveDocument.SaveAs FileName:="Facture_" & DocNum & ".doc"
ActiveDocument.Close
Application.Browser.Next
Next i
ActiveDocument.Close savechanges:=wdDoNotSaveChanges
End Sub
The function below will enable you to extract the first word (and optionally remove it) of a Word document.
Public Function GetFirstWord(Optional blnRemove As Boolean = True) As String
Dim rng As Range
Dim intCharCount As Integer
Dim strWord As String
With ThisDocument
Set rng = .Characters(1)
intCharCount = rng.EndOf(wdWord, wdMove)
With .Range(0, intCharCount - 1)
strWord = .Text
If blnRemove Then
.Delete
End If
End With
End With
GetFirstWord = strWord
End Function
I hope this helps.