Speeding up a VBA Script to Update MS Word Links - vba

I've got a VBA script that loops through a folder containing word docs, opening them, updating the links, saving and closing them and it's running slowly, about 20 seconds to cycle through one word doc.
I've tried searching for others having similar issues but I can't seem to figure out how to get their solutions to work in this code and I'm not very familiar with VBA.
I'm guessing the speed of the whole operation is related to the time it takes to open an instance of MS Word and close it out each time. Is there a way this can be done in the background or by keeping MS Word open and just opening & closing documents? There's a decent amount of files to get through so any tips on how to increase the speed would be much appreciated! Happy to provide any additional info if it helps.
Sub UpdateSpecHeaders()
Dim oWordApp As Object
Dim oWordDoc As Object
Dim sFolder As String, strFilePattern As String
Dim strFileName As String, sFileName As String
'> Folder containing files to update
sFolder = Range("A20").Value
'> Identify file extension to search for
strFilePattern = "*.doc"
'> Establish a Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
Application.ScreenUpdating = False
'> Loop through the folder to get the word files
strFileName = Dir$(sFolder & strFilePattern)
Do Until strFileName = ""
sFileName = sFolder & strFileName
'> Open the word doc
Set oWordDoc = oWordApp.Documents.Open(sFileName)
Application.DisplayAlerts = False
'> Update Fields
oWordApp.ActiveDocument.Fields.Update
'> Save and close the file
oWordDoc.Save
oWordDoc.Close SaveChanges:=True
'> Find next file
strFileName = Dir$()
Loop
'> Quit and clean up
Application.ScreenUpdating = True
oWordApp.Quit
Set oWordDoc = Nothing
Set oWordApp = Nothing
End Sub

Related

VBA to Batch Update Folder of MS Word Files with Excel Links

I've got a folder full of MS word docs, all with the same header, containing a couple of fields linked to an excel file to control the project phase and issue date in one spot.
I'm trying to figure out a way to use VBA to loop through all the word docs in this folder, opening them, updating the fields, saving and closing to avoid going through one by one and doing it manually.
Brand new to VBA here and not quite sure what I'm doing (or doing wrong). Here's the code I've pieced together so far based on responses I've seen related to this task. Any help is appreciated on how to improve this/tackle the problem. Happy to provide more info if it helps.
Receiving error "Object variable or With block variable not set" on line "Set oWordDoc = oWordApp.Documents.Open(sFileName)"
Thanks!
Update: Thank you everyone for the help, working code added below.
Sub Sample()
Dim oWordApp As Object, oWordDoc As Object, rngStory As Object
Dim sFolder As String, strFilePattern As String
Dim strFileName As String, sFileName As String
'> Change this to the folder which has the files
sFolder = Dir(Range("A20").Value)
'> This is the extention you want to go in for
strFilePattern = "*.doc"
'> Establish Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
'> Loop through the folder to get the word files
strFileName = Dir$(sFolder & strFilePattern)
Do Until strFileName = ""
sFileName = sFolder & strFileName
'> Open the word doc
Set oWordDoc = oWordApp.Documents.Open(sFileName)
'> Update Fields
oWordDoc.Fields.Update
'> Close the file after saving
oWordDoc.Close SaveChanges:=True
'> Find next file
strFileName = Dir$()
Loop
'> Quit and clean up
oWordApp.Quit
Set oWordDoc = Nothing
Set oWordApp = Nothing
End Sub
Updated Working Code:
Sub UpdateSpecHeaders()
Dim oWordApp As Object, oWordDoc As Object
Dim sFolder As String, strFilePattern As String
Dim strFileName As String, sFileName As String
'> Folder containing files to update
sFolder = Range("A20").Value
'> Identify file extension to search for
strFilePattern = "*.doc"
'> Establish a Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
'> Loop through the folder to get the word files
strFileName = Dir$(sFolder & strFilePattern)
Do Until strFileName = ""
sFileName = sFolder & strFileName
'> Open the word doc
Set oWordDoc = oWordApp.Documents.Open(sFileName)
Application.DisplayAlerts = False
'> Update Fields
oWordApp.ActiveDocument.Fields.Update
'> Save and close the file
oWordDoc.Save
oWordDoc.Close SaveChanges:=True
'> Find next file
strFileName = Dir$()
Loop
'> Quit and clean up
oWordApp.Quit
Set oWordDoc = Nothing
Set oWordApp = Nothing
End Sub

HOW To manipulate an ALREADY open word document from excel vba

I am new to VBA and obviously I am missing something. My code works for opening a word doc and sending data to it BUT does NOT for an ALREADY OPEN word doc. I keep searching for an answer on how to send info from Excel to an OPEN Word doc/Bookmark and nothing works.
I hope it is okay that I added all the code and the functions called. I really appreciate your help!
What I have so far
Sub ExcelNamesToWordBookmarks()
On Error GoTo ErrorHandler
Dim wrdApp As Object 'Word.Application
Dim wrdDoc As Object 'Word.Document
Dim xlName As Excel.Name
Dim ws As Worksheet
Dim str As String 'cell/name value
Dim cell As Range
Dim celldata As Variant 'added to use in the test
Dim theformat As Variant 'added
Dim BMRange As Object
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Set wb = ActiveWorkbook
strPath = wb.Path
If strPath = "" Then
MsgBox "Please save your Excel Spreadsheet & try again."
GoTo ErrorExit
End If
'GET FILE & path of Word Doc/Dot
strPathFile = strOpenFilePath 'call a function in MOD1
If strPathFile = "" Then
MsgBox "Please choose a Word Document (DOC*) or Template (DOT*) & try again." 'strPath = Application.TemplatesPath
GoTo ErrorExit
End If
If FileLocked(strPathFile) Then 'Err.Number = 70 if open
'read / write file in use 'do something
'NONE OF THESE WORK
Set wrdApp = GetObject(strPathFile, "Word.Application")
'Set wrdApp = Word.Documents("This is a test doc 2.docx")
'Set wrdApp = GetObject(strPathFile).Application
Else
'all ok 'Create a new Word Session
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
wrdApp.Activate 'bring word visiable so erros do not get hidden.
'Open document in word
Set wrdDoc = wrdApp.Documents.Open(Filename:=strPathFile) 'Open vs wrdApp.Documents.Add(strPathFile)<=>create new Document1 doc
End If
'Loop through names in the activeworkbook
For Each xlName In wb.Names
If Range(xlName).Cells.Count = 1 Then
celldata = Range(xlName.Value)
'do nothing
Else
For Each cell In Range(xlName)
If str = "" Then
str = cell.Value
Else
str = str & vbCrLf & cell.Value
End If
Next cell
'MsgBox str
celldata = str
End If
'Get format and strip away the spacing, negative color etc etc
'I know this is not right... it works but not best
theformat = Application.Range(xlName).DisplayFormat.NumberFormat
If Len(theformat) > 8 Then
theformat = Left(theformat, 5) 'was 8 but dont need cents
Else
'do nothing for now
End If
If wrdDoc.Bookmarks.Exists(xlName.Name) Then
'Copy the Bookmark's Range.
Set BMRange = wrdDoc.Bookmarks(xlName.Name).Range.Duplicate
BMRange.Text = Format(celldata, theformat)
'Re-insert the bookmark
wrdDoc.Bookmarks.Add xlName.Name, BMRange
End If
Next xlName
'Activate word and display document
With wrdApp
.Selection.Goto What:=1, Which:=2, Name:=1 'PageNumber
.Visible = True
.ActiveWindow.WindowState = wdWindowStateMaximize 'WAS 0 is this needed???
.Activate
End With
GoTo WeAreDone
'Release the Word object to save memory and exit macro
ErrorExit:
MsgBox "Thank you! Bye."
Set wrdDoc = Nothing
Set wrdApp = Nothing
Exit Sub
'Error Handling routine
ErrorHandler:
If Err Then
MsgBox "Error No: " & Err.Number & "; There is a problem"
If Not wrdApp Is Nothing Then
wrdApp.Quit False
End If
Resume ErrorExit
End If
WeAreDone:
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
file picking:
Function strOpenFilePath() As String
Dim intChoice As Integer
Dim iFileSelect As FileDialog 'B
Set iFileSelect = Application.FileDialog(msoFileDialogOpen)
With iFileSelect
.AllowMultiSelect = False 'only allow the user to select one file
.Title = "Please... Select MS-WORD Doc*/Dot* Files"
.Filters.Clear
.Filters.Add "MS-WORD Doc*/Dot* Files", "*.do*"
.InitialView = msoFileDialogViewDetails
End With
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strOpenFilePath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
Else
'nothing yet
End If
End Function
checking if file is open...
Function FileLocked(strFileName As String) As Boolean
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
' Display the error number and description.
MsgBox "Function FileLocked Error #" & str(Err.Number) & " - " & Err.Description
FileLocked = True
Err.Clear
End If
End Function
ANSWER BELOW. Backstory... So, after input from you guys and more research I discovered that I needed to set the active word document by using the file selection the user picked and that is then passed via late binding to the sub as an object to process. NOW it works if the word file is not in word OR if it is currently loaded into word AND not even the active document. The below code replaces the code in my original question.
Set Object app as word.
grab the file name.
Make the word doc selected active to manipulate.
Set the word object to the active doc.
THANK YOU EVERYONE!
If FileLocked(strPathFile) Then 'Err.Number = 70 if open
'read / write file in use 'do something
Set wrdApp = GetObject(, "Word.Application")
strPathFile = Right(strPathFile, Len(strPathFile) - InStrRev(strPathFile, "\"))
wrdApp.Documents(strPathFile).Activate ' need to set picked doc as active
Set wrdDoc = wrdApp.ActiveDocument ' works!
This should get you the object you need.
Dim WRDFile As Word.Application
Set WRDFile = GetObject(strPathFile)
'Have Microsoft Word 16.0 Object Library selected in your references
Dim wordapp As Object
Set wordapp = GetObject(, "Word.Application")
wordapp.Documents("documentname").Select
'works if you only have one open word document. In my case, I'm trying to push updates to word links from excel.

How to save Word document in specified folder with filedialog.saveas?

I used the MO 14.0 Object library.
I want to open the filedialog.saveas where the user can choose the folder to save a Word document. Then open the document and write data from an Access database.
I found how to open, to fill in the data and how to open the filedialog.
The problem is that the chosen datafile is not saved at the location where it should be.
Private Sub Befehl44_Click()
Dim objWord As Object
Set objWord = CreateObject("Word.Application")
With objWord
.Visible = True
.Documents.Open (CurrentProject.Path & "\template.docx") 'template for word document
.activedocument.Bookmarks("email").Select
.Selection.Text = Me!email
.activedocument.Bookmarks("name").Select
.Selection.Text = Me!name
.Application.FileDialog(msoFileDialogSaveAs).Show
strPath = Application.FileDialog(msoFileDialogSaveAs).SelectedItems(1)
End With
Set objWord = Nothing
End Sub
Does strPath return the correct filepath the user selected for saving?
If it does, you just need to call the SaveAs method directly from Word
After
strPath = Application.FileDialog(msoFileDialogSaveAs).SelectedItems(1)
Insert Lines
If strPath <> "" Then
.ActiveWorkbook.SaveAs strPath
End If
Or - just replace it with one line
ActiveWorkbook.SaveAs filename:=Application.GetSaveAsFilename

Two clicks to generate word document from access form, with double rich text copied using vba

I've been working in exporting a rtf (rich text) form a memo field in access 2010 to a word file with a bookmark. The problem is that It is necessary two clicks to open the word document, and then, the text is inserted twice. I'm still not able to find the problem.
Here is the code:
Option Compare Database
Private Sub Comando72_Click()
'Saves the current record -->
Me.Dirty = False
Dim appWord As Word.Application
Dim doc As Word.Document
Dim objWord As Object '' Word.Application
Dim fso As Object '' FileSystemObject
Dim f As Object '' TextStream
Dim myHtml As String
Dim tempFileSpec As String
' grab some formatted text from a Memo field
myHtml = DLookup("DescripActivAEjecutarse", "PlanificacionServiciosInstitucionales", "IdPSI = Form!IdPSI")
Set fso = CreateObject("Scripting.FileSystemObject") '' New FileSystemObject
tempFileSpec = fso.GetSpecialFolder(2) & "\" & fso.GetTempName & ".htm"
'' write to temporary .htm file
Set f = fso.CreateTextFile(tempFileSpec, True)
f.Write "<html>" & myHtml & "</html>"
f.Close
Set f = Nothing
Set fso = Nothing
'Set appWord object variable to running instance of Word.
Set appWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then
'If Word isn't open, create a new instance of Word.
Set appWord = New Word.Application
End If
'set the doc for future use.
Set doc = appWord.Documents.Open("C:\Users\earias\Documents\SOLICITUD-Yachay-automatica2.docx", , True) 'True default (just reading).
'locates bookmark and inserts file
appWord.Selection.GoTo what:=wdGoToBookmark, Name:="bookmark_1"
appWord.Selection.InsertFile tempFileSpec
Set doc = Nothing
Set appWord = Nothing
Exit Sub
errHandler:
MsgBox Err.Number & ": " & Err.Description
End Sub
If you are pressing the button twice it will run the procedure twice?
In terms of your current code,
after this line Set doc = appWord.Documents.Open add the following;
doc.visible = true
This should enable you to view the document that's open when you press the button once. To prevent the window from popping up you could also instead of setting it to visible do;
doc.saveas "path here"
then set all to nothing and close off as you would and the file will be saved where you want it saved without needing to manually save as each time.
You could look at setting up a simple mail merge with a template and then saving-as the template to whichever format you choose and break the mailmerge link (my preferred method).
Let me know how you get on!

Find and Replace text within all .docm in a folder using VBA incrementing replace variable

Siddharth Rout posted very closely what I am looking for in another post. The only issue is that when the script loops through the files in the directory I need the replace variable to increase. For example, my files are named 001 - Wordfile.docm, 002 - wordfile2.docm, and so on. So for the first file the find would be 001X replace 001X, then loop to next file and find 001X replace 002x, next file 001X replace with 003X and so on. The reason for this is that we duplicate the 001 file 350 times but then need to change the excel links in the word doc to point to the appropriate worksheet in excel. I hope I made this clear and not more complicated. Anyway, here is the code that Sid posted. How can I add to the script to change the replace value while looping through the docs.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' This code uses Late Binding to connect to word and hence you '
' you don't need to add any references to it '
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Option Explicit
'~~> Defining Word Constants
Const wdFindContinue As Long = 1
Const wdReplaceAll As Long = 2
Sub Sample()
Dim oWordApp As Object, oWordDoc As Object, rngStory as Object
Dim sFolder As String, strFilePattern As String
Dim strFileName As String, sFileName As String
'~~> Change this to the folder which has the files
sFolder = "C:\LQ\"
'~~> This is the extention you want to go in for
strFilePattern = "*.docm"
'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
'~~> Loop through the folder to get the word files
strFileName = Dir$(sFolder & strFilePattern)
Do Until strFileName = ""
sFileName = sFolder & strFileName
'~~> Open the word doc
Set oWordDoc = oWordApp.Documents.Open(sFileName)
'~~> Do Find and Replace
For Each rngStory In oWordDoc.StoryRanges
With rngStory.Find
.Text = "001X"
.Replacement.Text = Left(strFileName,3) & "X"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next
'~~> Close the file after saving
oWordDoc.Close SaveChanges:=True
'~~> Find next file
strFileName = Dir$()
Loop
'~~> Quit and clean up
oWordApp.Quit
Set oWordDoc = Nothing
Set oWordApp = Nothing
End Sub
With rngStory.Find
.Text = "001X"
.Replacement.Text = Left(strFileName,3) & "X"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With