Excel to Word VBA Export - Word Documents Not Being Created - vba

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.

Related

Replacing text in Word doc with text from Excel

I am looking to create a via script in excel that will replace a text holder in a word doc with some text from excel.
I can get the via script to open the word doc, and then save the doc under a new name. however it will not execute the replace text part :(
Private Sub CommandButton1_Click()
Dim wdApp As Object
Dim wdDoc As Object
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = False
Set wdDoc = wdApp.Documents.Open("temp.docx")
With wdDoc.Content.Find
.ClearFormatting
.Text = "<<name>>"
With .Replacement
.ClearFormatting
.Font.Bold = True
.Text = "John Smith"
End With
.Execute Replace:=wdReplaceAll
End With
wdDoc.SaveAs2 Filename:=("temp2.docx")
Set wdApp = Nothing
Set wdDoc = Nothing
End Sub
I have tried doing a search in here but can't see where I am going wrong :(
currently it opens the word doc and saves it under a new name but does not replace the find and replace the text. Can anyone see where I have gone wrong and show me how to get it right?
When I set up a test for your problem description in Word, by typing <<name>> I see that Word replaces the two angled brackets with special symbols. And it offers the possibility to undo the AutoCorrect causing this.
Querying ASC(Selection.Text) on them gives Chr(171) and Chr(187), which are also double-angled bracket symbols, but using them in Find does not work. Querying AscW() reveals the two symbols are Unicode 8810 and 8811, so they need to be searched differently.
Assuming that's the issue in your case, the following works:
With wdDoc.content.Find
.ClearFormatting
.Text = ChrW(8810) & "name" & ChrW(8811) '"<<name>>"
With .Replacement
.ClearFormatting
.Font.Bold = True
.Text = "John Smith"
End With
.Execute Replace:=wdReplaceAll
End With
Further to your code - it has other, potentially grave problems (memory leak):
If you do this: wdApp.Visible = False then you need to be absolutely certain to remove Word from memory:
wdDoc.Close
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
Unlike Excel, Word won't quit automatically when its object goes out of scope (macro ends). It will stay open, which you can see in the Task Manager.
In addition, you need to release the objects in the reverse order in which they were instantiated - wdDoc before wdApp.
Setup some DocVariables in your Word doc and run the code below, from within Excel.
Sub PushToWord()
Dim objWord As New Word.Application
Dim doc As Word.Document
Dim bkmk As Word.Bookmark
sWdFileName = Application.GetOpenFilename(, , , , False)
Set doc = objWord.Documents.Open(sWdFileName)
'On Error Resume Next
objWord.ActiveDocument.variables("BrokerFirstName").Value = Range("BrokerFirstName").Value
objWord.ActiveDocument.variables("BrokerLastName").Value = Range("BrokerLastName").Value
objWord.ActiveDocument.variables("Ryan").Value = Range("Ryan").Value
objWord.ActiveDocument.Fields.Update
'On Error Resume Next
objWord.Visible = True
End Sub
You can use essentially the same process by setting up Bookmarks in Word, and pushing data from fields in Excel to fields (Bookmarks) in Word.
Sub PushToWord()
Dim objWord As New Word.Application
Dim doc As Word.Document
Dim bkmk As Word.Bookmark
sWdFileName = Application.GetOpenFilename(, , , , False)
Set doc = objWord.Documents.Open(sWdFileName)
On Error Resume Next
ActiveDocument.Variables("BrokerFirstName").Value = Range("B1").Value
ActiveDocument.Variables("BrokerLastName").Value = Range("B2").Value
ActiveDocument.Fields.Update
On Error Resume Next
objWord.Visible = True
End Sub
The famouse hope - to have one button for all live cases with caption: "Make it OK!"
Do divide the task on parts:
- Get "... text from excel ..."
- "replace text in word doc ..." with text getted from Excel on previouse step
Do it by two separate procedures for each of tasks,
called from the third procedure united them.
.

VBA Access - Find and Replace text in Word Document

I have successfully written some VBA code in Excel which opens an existing Word document, finds and replaces a string based on information in the Excel worksheet.
As the source data exists comes from an Access Database, I thought I would try and move the VBA code into Access and run it from there.
The updated code works mostly but strangely, the part of the code which finds and replaces the text string doesn't work when I run it in access.
Sub CreateFormsPDF()
' Creates Garda Vetting Forms NVB1 in Word and saves as PDF
Dim WordApp As Object
Dim WordDoc As Object
Dim db As Database
Dim rs As Recordset
Dim Records As Integer
Dim IDAnchor As String
Dim ID As String
Dim FilePath As String, SaveAsName As String
FilePath = "N:\"
' Start Word and create an object (late binding)
' Document already exists so reference this
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Open(FilePath & "Form1.docx")
WordApp.Application.Visible = True
' Point to the relevant table in the Current Database
Set db = CurrentDb
Set rs = db.OpenRecordset("qryMailingList", dbOpenDynaset, dbSeeChanges)
Records = rs.RecordCount
' Cycle through all records in MailingList Query
Do Until rs.EOF
' Define IDAnchor
IDAnchor = "$$ID$$"
' Assign current data to variables
ID = rs!StudentID
' Determine the filename
SaveAsName = FilePath & ID & ".pdf"
' Send commands to Word
With WordApp
With WordDoc.Content.Find
.Text = IDAnchor
.Replacement.Text = ID
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
.ActiveDocument.SaveAs2 FileName:=SaveAsName, FileFormat:=17
End With
IDAnchor = ID
rs.MoveNext
Loop
WordApp.Quit savechanges:=wdDoNotSaveChanges
Set WordApp = Nothing
Set WordDoc = Nothing
Set rs = Nothing
Set db = Nothing
MsgBox Records & " Forms Created"
End Sub
The code executes fine, with one exception which is the Find and Replace element in Word i.e.
' Send commands to Word
With WordApp
With WordDoc.Content.Find
.Text = IDAnchor
.Replacement.Text = ID
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
.ActiveDocument.SaveAs2 FileName:=SaveAsName, FileFormat:=17
End With
What is even stranger is that I have a version of this code running via Excel and this runs without any problems at all and I've lifted this section of code from that subroutine exactly as is. So this works in Excel, but not in Access but I've no idea why.
Would really appreciate any help that might be available
Many thanks...
Actually I've just figured it out myself...I hadn't referenced the Word object library under tools.
Always something simple!

Copy and paste INCLUDING bookmarks 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.

Use VBS to copy from Notepad to Word

I'm trying to create a script to convert PDF to plain text, then copy the plain text into Word. (We do a lot of reformatting corrupt documents from scratch where I work.) I have a script that's working perfectly except for one thing: when pasting into Word, it doesn't paste the whole file. With longer files, I'm only getting part of the text.
'string to hold file path
Dim strDMM
strDMM = "[path]"
'make this directory if it doesn't exits
On Error Resume Next
MkDir strDMM
On Error GoTo 0
'get the file name to process
Dim TheFile
TheFile = InputBox("What is the file name?" & chr(13) & chr(13) & "(Example: [name].pdf)", "Name of File")
'declare some acrobat variables
Dim AcroXApp
Dim AcroXAVDoc
Dim AcroXPDDoc
'open acrobat
Set AcroXApp = CreateObject("AcroExch.App")
AcroXApp.Hide
'open the document we want
Set AcroXAVDoc = CreateObject("AcroExch.AVDoc")
AcroXAVDoc.Open "[path to desktop]" & TheFile, "Acrobat" 'users are instructed to save to the Desktop for ease of access here
'make sure the acrobat window is active
AcroXAVDoc.BringToFront
'I don't know what this does. I copied it from code online.
Set AcroXPDDoc = AcroXAVDoc.GetPDDoc
'activate JavaScript commands w/Acrobat
Dim jsObj
Set jsObj = AcroXPDDoc.GetJSObject
'save the file as plain text
jsObj.SaveAs strDMM & "pdf-plain-text.txt", "com.adobe.acrobat.plain-text"
'close the file and exit acrobat
AcroXAVDoc.Close False
AcroXApp.Hide
AcroXApp.Exit
'declare constants for manipulating the text files
Const ForReading = 1
Const ForWriting = 2
'Create a File System Object
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
'read file and get text
dim objFile
set objFile=objFSO.OpenTextFile( strDMM & TheFile, ForReading)
Dim strText
strText=objFile.ReadAll
'Create a Word Object
Dim objWord
set objWord = CreateObject("Word.Application")
'make Word visible
With objWord
.Visible = True
End With
'Add method used to create a blank document
Dim objDoc
Set objDoc=objWord.Documents.Add()
'create a shorter variable to pass commands to Word
Dim objSelection
set objSelection=objWord.Selection
'type the read text into Word; this is the part that's failing
objSelection.TypeText strText
objFile.Close
I've tried multiple files with the same result. The funny thing is, it pastes the same material from file A each time, but when copying from file B, it pastes a different amount of material. In other words, if A gives me 8 pages of 60 on the first run, I get those same 8 pages each time. File B might give me 14 pages of 60, then it gives me the same 14 pages each time. This only changes if I delete material from the .txt file. If I delete several paragraphs from A, then run the script, I might get 12 pages. Then I get those same 12 every time. But there's no pattern (that I can discern) to predict where it cuts off.
I can't find any EOF characters, and when I read from notepad and write to notepad, the whole thing is copied perfectly. The problem is somewhere in the transfer to Word.
Is there something I'm missing? Is there a limit to the size of a string that Word can write with TypeText? (I would think that if that were the case, I wouldn't get documents of varying length, right? Shouldn't they all stop at n characters if that's the limit?)
I've read about additional libraries that let VBS work with the clipboard, but I'm a total noob and don't know if that's a more elegant solution or how to make it work. I'm also not sure that on my work computer I have the necessary access to install those libraries.
Any help is appreciated!
There is no need to read a file into Word, you can insert a text file from disk
Dim objWord
'Dim objDoc
Set objWord = CreateObject("Word.Application")
'make Word visible
With objWord
.Visible = True
'Add method used to create a blank document
.Documents.Add
.Selection.InsertFile FileNameAndPath
End With
The basic problem, which you hinted at, is that the String data type is limited to 65,400 characters. With an unknown file length, it is better to read in one line at a time and write it to Word. There is a good discussion of something similar here. The following code should help you get where you wan to go:
'read file and get text
dim objFile
set objFile=objFSO.OpenTextFile( strDMM & TheFile, ForReading)
'Don't do this!
'Dim strText
'strText=objFile.ReadAll
'Create a Word Object
Dim objWord
set objWord = CreateObject("Word.Application")
'make Word visible
With objWord
.Visible = True
End With
'Add method used to create a blank document
Dim objDoc
Set objDoc=objWord.Documents.Add()
'create a shorter variable to pass commands to Word
Dim objSelection
set objSelection=objWord.Selection
'Read one line at a time from the text file and
'type that line into Word until the end of the file is reached
Dim strLine
Do Until objFile.AtEndOfStream
strLine = objFile.ReadLine
objSelection.TypeText strLine
Loop
objFile.Close
Hope that helps!

Word macro that adds the file name to the body text of a series of Word documents in a folder

I need a Word macro that adds the file name of a document to the first line of that Word document. But not just one document at a time. I would like the Macro to add these file names to a series of Word documents in a particular folder (with each document getting their own file name).
A Macro that adds the file name to document is simple:
Selection.HomeKey Unit:=wdStory
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
Text:= "FILENAME "
Selection.TypeParagraph
But how can I get it to add file names to an entire series of documents in a folder? I suppose the folder could be named in the Macro. For example: C:\Users\username\Desktop\somefolder\. I also suppose that a Loop could be used to go through the folder until the loop gets to the end of the documents in the folder.
This should at least get you started. I haven't tested it, but I've written this type of thing a few times before, so the basic idea works.
Dim filePath As String
Dim thisDoc As Document
Dim wordApp As Word.Application
Set wordApp = New Word.Application
'wordApp.Visible = True ' uncomment if you want to watch things happen
'Get first file that matches
filePath = Dir("C:\Users\username\Desktop\somefolder\*.doc") ' or *.whatever
Do While filePath <> ""
Set thisDoc = wordApp.Documents.Open(filePath)
'Add filename at top of document
Selection.HomeKey Unit:=wdStory
Selection.InsertAfter filePath
'Selection.InsertAfter ThisDocument.FullName ' alternative
'Your way using .Fields.Add is also fine if you want the file name as
' a field instead of
' plain text.
thisDoc.Close SaveChanges:=True
'Get next file that matches and start over
filePath = Dir()
Loop
wordApp.Quit
Set wordApp = Nothing