I have a macro in an Excel workbook that currently does the following:
Create a data.csv file with data in the first two rows (for a mail merge)
Pull a template of a selected Word document and make the data.csv file the source for the mail merge
If the user chooses, it finishes the merge for the document
If the user chooses, it opens the document when the macro is complete. If they don't choose to open, the word documents all close.
I've been running into a couple major issues:
The macro only seems to run smoothly if Word is entirely closed beforehand. My current workaround is a popup message if Word is open, telling the user to close word, but this is not ideal because it disrupts flow for some users who may have several instances of Word open.
The macro has been running slowly, especially for some of the document templates that have thousands of merge fields pre-entered in the template. It sometimes take longer than a minute, and sometimes completely freezes.
Would the macro would run more smoothly if I have the Excel VBA open the Word template and have most of the code for setting up and finishing the mail merge in Word VBA? I'm much less familiar with Word VBA - can anyone help me with bringing over my code to word (but still initiated by Excel)? Also, if you can figure out why the macro struggles when Word is already open, I'd greatly appreciate it.
I didn't include the entire code for proprietary reasons, but please let me know if there's something else you need to see.
Thank you!!
Sub Mail_Merge_Dynamic()
Dim mergeFile, tempFilePath As String
Dim WordDoc, WordApp As Object
Dim tempPath, mergePath, finalPath, curDir As String
Dim mergeFilePath, finalFilePath As String
Dim dataPath, FileNameCell, PrincCertCell, MMPrefix As String
Dim FileCount As Integer
Dim Close_Choice, ActiveWindow As String
Dim WarningMsg, WarningMsg2 As String
Dim NotFound, Overwrite1, Overwrite2 As Boolean
Dim oBook As Workbook
'Update csv file for Data Merge
narrative_merge
Call WarpSpeed_On
Sheets("Navigation").Select
Range("Merge_File_1").Select
Set WordApp = CreateObject("Word.Application")
'//////////////////////////////MAIL MERGE MACRO\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'Set up Mail Merge Documents from Template Folder based on selections on Navigation tab
For i = 1 To FileCount
FileNameCell = "Merge_File_" & i
If Range(FileNameCell) = "" Then
Else
mergeFile = Range(FileNameCell)
tempFilePath = tempPath & mergeFile
mergeFilePath = mergePath & "MM_" & mergeFile
finalFilePath = finalPath & mergeFile
'Activate Mail Merge
If Range("MM_Activate") = 0 Then
Else
Set WordDoc = WordApp.Documents.Open(tempFilePath)
With WordDoc.MailMerge
.MainDocumentType = wdFormLetters
'Set up the mail merge data source
dataPath = curDir & "\data.csv"
.OpenDataSource Name:=dataPath
'Show values in the mail merge fields
.ViewMailMergeFieldCodes = wdToggle
End With
'WordDoc.ShowFieldCodes = False
'WordDoc.MailMerge.ViewMailMergeFieldCodes = False
WordDoc.SaveAs FileName:=mergeFilePath
End If
' Finish mail merge
If Range("MM_Finish") = 0 Then
Else
With WordDoc.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
.Execute Pause:=False
End With
WordDoc.Application.ActiveDocument.SaveAs finalFilePath
End If
End If
Next i
Call CloseWordDocuments
'Make word visible if an Open command has been selected
If Range("MM_Open_Merge") = 1 Or Range("MM_Open_Doc") = 1 Then
curDir = ThisWorkbook.Path
Set WordApp = CreateObject("Word.Application")
For i = 1 To FileCount
FileNameCell = "Merge_File_" & i
If Range(FileNameCell) = "" Then
Else
mergeFile = Range(FileNameCell)
mergeFilePath = curDir & "\Merge-Active Forms\" & "MM_" & mergeFile
finalFilePath = curDir & "\Merge-Complete Forms\" & mergeFile
If Range("MM_Open_Merge") = 1 Then
Set WordDoc = WordApp.Documents.Open(mergeFilePath)
End If
If Range("MM_Open_Doc") = 1 Then
Set WordDoc = WordApp.Documents.Open(finalFilePath)
End If
End If
Next i
WordApp.Visible = True
'Windows(mergeFile).Activate
End If
GoTo Reset
Reset:
Call WarpSpeed_Off
End Sub
Sub WarpSpeed_On_Calcs_Off()
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' Turn off display alerts
Application.DisplayAlerts = False
End Sub
Sub WarpSpeed_On()
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
' Turn off display alerts
Application.DisplayAlerts = False
End Sub
Sub WarpSpeed_Off()
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Instead of:
Set WordApp = CreateObject("Word.Application")
this will open Word if it is not already open:
Set WordApp = GetObject(, "Word.Application")
Edit#1
In VBA you may do something like:
On Error GoTo CreateObj
' Is Word application already running ?
Set WordApp = GetObject(, "Word.Application")
GoTo gotApp
CreateObj:
' Not running, create first instance:
Set WordApp = CreateObject("Word.Application")
gotApp:
On Error GoTo 0 ' disable error handling
' continue
....
....
Related
I have a folder with a few hundred-word documents. I want to be able to replace the words ORG NAME by clicking a macro, filling in an input box and letting it iterate. There are thousands of instances of ORG NAME across these documents and this process needs to happen a few dozen times a year.
We've got some challenges with trust centre policies in place that can't be changed so the macro needs to be done via excel.
The below was sort of working as word macro although it was crashing a lot, I moved it over to excel and now I'm getting the error: Named argument not found against macroname:
I can't find any similar questions that aren't solved by correcting spelling.
I'm also open to better solutions if they exist, this has been my first attempt so far.
Sub Button1_Click()
Dim xFileDialog As FileDialog, GetStr(1 To 300) As String '300 files is the maximum applying this code
Dim xFindStr As String
Dim xReplaceStr As String
Dim xDoc As Object
On Error Resume Next
Set xFileDialog = Application.FileDialog(msoFileDialogFilePicker)
With xFileDialog
.Filters.Clear
.Filters.Add "All WORD File ", "*.docx", 1
.AllowMultiSelect = True
i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Application.ScreenUpdating = False
xFindStr = "ORG NAME"
xReplaceStr = InputBox("Enter the name of the organisation:", "Document Updater for Word", xReplaceStr)
For j = 1 To i Step 1
Set xDoc = Documents.Open(Filename:=GetStr(j), Visible:=True)
Windows(GetStr(j)).Activate
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = xFindStr 'Find What
.Replacement.Text = xReplaceStr 'Replace With
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Application.Run macroname:="NEWMACROS"
ActiveDocument.Save
ActiveWindow.Close
Next
Application.ScreenUpdating = True
End With
MsgBox "Operation end, please view", vbInformation
End Sub
See this page by Ibby on the Word MVP website.
How to Find & ReplaceAll on a batch of documents in the same folder
The following code, if stored in a Global template, will perform a
Find & ReplaceAll in all of the documents in a specified folder. The
FindReplace dialog is displayed for the first document only. The user
sets the parameters in the dialog and presses Replace All and then
Close. The user is then asked whether to process all of the files in
the specified directory – if Yes, the rest of the files are processed
with the settings as entered in the original FindReplace dialog.
Option Explicit
Public Sub BatchReplaceAll()
Dim FirstLoop As Boolean
Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim Response As Long
PathToUse = "C:\Test\"
'Error handler to handle error generated whenever
'the FindReplace dialog is closed
On Error Resume Next
'Close all open documents before beginning
Documents.Close SaveChanges:=wdPromptToSaveChanges
'Boolean expression to test whether first loop
'This is used so that the FindReplace dialog will
'only be displayed for the first document
FirstLoop = True
'Set the directory and type of file to batch process
myFile = Dir$(PathToUse & "*.doc")
While myFile <> ""
'Open document
Set myDoc = Documents.Open(PathToUse & myFile)
If FirstLoop Then
'Display dialog on first loop only
Dialogs(wdDialogEditReplace).Show
FirstLoop = False
Response = MsgBox("Do you want to process " & _
"the rest of the files in this folder", vbYesNo)
If Response = vbNo Then Exit Sub
Else
'On subsequent loops (files), a ReplaceAll is
'executed with the original settings and without
'displaying the dialog box again
With Dialogs(wdDialogEditReplace)
.ReplaceAll = 1
.Execute
End With
End If
'Close the modified document after saving changes
myDoc.Close SaveChanges:=wdSaveChanges
'Next file in folder
myFile = Dir$()
Wend
End Sub
That should get you started. The page has more on subfolders and password protected files.
If you need to do more than find and replace, see also utilities for batch processing documents by Greg Maxey and by Graham Mayor.
I am using an interface made with Excel to allow users to concurrently edit a shared data file. To prevent multiple users from editing at the same time I made the following function to do the following:
Open the file
If the file was opened as a read-only, close the file and re-open until the file is opened as read-write or the maximum number of allowed attempts is crossed.
Function OpenTillCanEditC(refpath As String, pw As String) As Workbook
Dim wbtoopen As Workbook
Dim maxOpen As Long
Dim i As Long
Dim buttonClicked As Long
maxOpen = 10
i = 0
On Error GoTo ErrHandler:
Application.DisplayAlerts = False
Set wbtoopen = Workbooks.Open(refpath, True, Password:=pw, ReadOnly:=False)
Application.DisplayAlerts = True
While wbtoopen.ReadOnly And i < maxOpen
If wbtoopen.ReadOnly Then
wbtoopen.Close (False)
Application.Wait (Now + TimeValue("00:00:01"))
Set wbtoopen = Nothing
i = i + 1
If i >= maxOpen Then
buttonClicked = MsgBox("It appears the masterlist is currently being used by someone else. Do you want to retry opening?", vbRetryCancel)
If buttonClicked = vbRetry Then
maxOpen = maxOpen + 10
Application.DisplayAlerts = False
Set wbtoopen = Workbooks.Open(refpath, True, Password:=pw, ReadOnly:=False)
Application.DisplayAlerts = True
End If
Else
On Error GoTo ErrHandler:
Application.DisplayAlerts = False
Set wbtoopen = Workbooks.Open(refpath, True, Password:=pw, ReadOnly:=False)
Application.DisplayAlerts = True
End If
End If
Wend
Set OpenTillCanEditC = wbtoopen
Exit Function
ErrHandler:
Application.DisplayAlerts = True
If Err.Number = 1004 Then
MsgBox "The password keyed in is wrong."
Else
MsgBox "The masterlist found in " & refpath & " cannot be opened. It may be used by someone else or corrupted. If corrupted please open the file manually using Excel."
End If
Set wbtoopen = Nothing
Set OpenTillCanEditC = wbtoopen
End Function
OpenTillCanEditC will be used in a sub for updating as shown below:
Sub UpdateFile()
'Try to open
Dim datawb As Workbook
Dim filepath As String
Dim pw As String
filepath = "C:\Folder Containing File\Data File.xlsx"
pw = "password"
Set datawb = OpenTillCanEditC(filepath, pw)
If datawb Is Nothing Then
MsgBox "File cannot be opened or is currently in use."
Exit Sub
End If
'Do functions needed in the workbook here
datawb.Save()
datawb.Close
End Sub
However I keep getting either of the following two errors:
When multiple people are attempting to access the file, the OpenTillCanEditC function will still ask for a password even though it is already being keyed in.
datawb.Save() will sometimes throw an error stating that the save failed due to multiple users accessing the file.
How do I fix both of these issues to allow multiple users to edit a shared password-protected file using VBA?
I have script that printing specific file, but it's getting hard to make over 150 .vbs files for each document to be printed,
is there any way to have pop-out window where i can type file name, then script find it in folder and print it with 20 copies.
I have PDF, WORD and Excel files
this is what i have now for them
Dim AppExcel
Set AppExcel = CreateObject("Excel.application")
AppExcel.Workbooks.Open"directory\filename.xlsx"
AppExcel.Visible = True
AppExcel.ActiveWindow.SelectedSheets.PrintOut,,20
Appexcel.Quit
Set appExcel = Nothing
filename = "\\MCSERVER01\Data\Forms\Vehicle inspection forms\daily vehicle inspection form.pdf"
Set sh = CreateObject("WScript.Shell")
sh.Run "sumatrapdf.exe -print-to-default """ & filename & """", 0, True
Dim AppWord
Set AppWord = CreateObject("Word.application")
AppWord.Documents.Open"\\MCSERVER01\Data\Forms\DODD\SMALL CAR DRIVERS\Akira Litman.docx"
AppWord.Visible = True
AppWord.ActiveDocument.PrintOut
AppWord.Quit
Set appWord = Nothing
Perhaps you can make use of an input box
Dim fileToPrint As String
fileToPrint = InputBox("Enter file name to print")
I got some help from my old friend, but now i can't get another part working
set fso = CreateObject("Scripting.FileSystemObject")
call main
sub main
InputName = InputBox("ENTER YOUR NAME")
if instr(InputName, ".") = 0 then
msgbox("DON'T NEED THIS AT ALL!!!!!")
exit sub
end if
'msgbox(mid(InputName, instr(InputName, ".")+1))
select case mid(InputName, instr(InputName, ".")+1)
case "xlsx"
call printExcel(InputName)
end select
end sub
sub printExcel(fileName)
Dim AppExcel, path
Set AppExcel = CreateObject("Excel.application")
path = "\MCSERVER01\Data\Forms\Access2Care\WHEELCHAIR DRIVERS\"
if fso.FileExists(path & fileName) then
AppExcel.Workbooks.Open path & fileName
AppExcel.Visible = false
AppExcel.ActiveWindow.SelectedSheets.PrintOut,,20
Appexcel.Quit
Set appExcel = Nothing
else
X=MsgBox ("Wrong File Name Or File Doesn't Exist" ,0+16, "Please Re-Enter Your Full Name")
end if
end sub
so the issue i have now is that i have to type in file extension to make it work otherwise im getting msgbox with "don't need this"
how i can get rid of that msg and just have default extension as xlsx xsl
I'm trying to write a vbscript to be able to checkout an excel file that is stored on sharepoint server.
Currently I can check the file out from SharePoint 2010: Link to open Excel file in edit-mode mode
However, I'm trying to check the file back in but not able to. I've searched and tried the checkout functions per http://msdn.microsoft.com/en-us/library/office/ff194456%28v=office.14%29.aspx but not able to.
Currently the code I have is
Sub CheckInFile
Dim ExcelApp, ExcelSheet, ExcelBook
Dim myURL
myURL = "http://server/Site/excel.xlsx"
Set ExcelApp = CreateObject("Excel.Application")
If (ExcelApp.WorkBooks.CanCheckIn(myURL) = True) Then
msgbox ("here")
ExcelApp.WorkBooks.Open (myURL)
ExcelApp.Application.WorkBooks.CheckIn myURL
ExcelApp.ActiveWorkbook.Close
' Quit Excel.
ExcelApp.Quit
' Clean Up
Set ExcelApp= Nothing
End If
End Sub
However the script stops and fails at the if statement, rather doesn't execute. Is there a similar vbscript function to check in a file ?
I struggled a LOT with this and spent many hours searching for a solution that worked in my particular environment. Here are my criteria that needed to be met:
Execute the process from my computer using vbscript file
Iterate through a list of ~200 excel spreadsheets
Check out each file
Make various conditional updates and save
Check the file back in again when updates are complete.
Below is an alternate solution for anybody in the future that, like me, tried the suggested approach and it didn't work. This is tested and working:
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.DisplayAlerts = False
Dim MyVar ' so popup alerts narrate the process
' and help explain what is happening
' for those who want to see it step
' by step
Dim docPath
docPath = "\\your server\sites\Docs\sharepoint spreadsheet.xlsx"
' I believe this can be any document path
Set objWorkbook = objExcel.Workbooks.Open(docPath)
cco = objExcel.Workbooks.CanCheckOut(docPath)
MyVar = MsgBox ("can check out? " & cco, 0)
' -----------------------------------------------------
' this shows "False" every time. I still do not know how
' to get this to work, but thought it would be valuable
' to include for explanation
' -----------------------------------------------------
objExcel.Workbooks.CheckOut(docPath)
' -----------------------------------------------------
' this SUCCEEDS every time...as long as you have
' the ability to check out the document manually
' -----------------------------------------------------
MyVar = MsgBox ("Update cell", 0)
With objExcel.ActiveWorkbook.Worksheets(1)
objExcel.Cells( 1, 1 ).Value = "test value"
End With
MyVar = MsgBox ("Save the file", 0)
objWorkbook.Save
MyVar = MsgBox ("check in the file", 0)
objWorkbook.CheckIn
' -----------------------------------------------------
' This actually checks in the active document and *closes
' it* You don't have to have a separate command to close
' the file, e.g.
' objWorkbook.Close
' THIS WILL FAIL.
' -----------------------------------------------------
Set objWorkbook = Nothing
Just try this:
Dim ExcelApp, ExcelSheet, ExcelBook
Dim myURL = "http://server/Site/excel.xlsx"
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.WorkBooks.Open (myURL)
If (ExcelApp.ActiveWorkbook.CanCheckIn = True) Then
ExcelApp.Application.WorkBooks(myURL).CheckIn
ExcelApp.ActiveWorkbook.Close
' Quit Excel.
ExcelApp.Quit
' Clean Up
Set ExcelApp= Nothing
End If
Just change include below lines to your code:
ExcelApp.Visible = True
ExcelApp.DisplayAlerts = False
Thanks!
Dim oExcel
Dim strFileName
Set oExcel = CreateObject("Excel.Application")
oExcel.Visible = True
oExcel.DisplayAlerts = False
strFileName = "view_2019.xlsm"
'Checkin
If oExcel.Workbooks(strFileName).CanCheckIn = True Then
oExcel.Workbooks(strFileName).CheckIn SaveChanges=True,Comments="Updated"
MsgBox strFileName & " has been checked in."
Else
MsgBox "This file cannot be checked in at this time. Please try again later."
End If
set oExcel = nothing
I have a project where I maintain a list of all my students and their information in an Excel file labeled "BigList.xlsx". Then, I have about 40-50 other separate ancillary excel files that link to BigList by using VLOOKUP.
For example, in cell A1 of an ancillary file you might see a formula that looks like this:
=Vlookup(B3,
'c:\documents and settings\user\desktop\[BigList.xlsx]Sheet1'!$a$1:$b$10000,
2,false).
The vlookup link above references BigList.xlsx. However, I just realized that I need to change that file name to something else, like MasterDatabase.xlsm (notice the different extension). Is there an easy way to do this without having to manually go through all 40-50 files and doing a find & replace?
I think the basic idea is to change a hardcoded link into a dynamic one where I can change the filename of BigList.xlsx anytime, and not have to go back through all 40-50 files to update their links.
This should do what you require - maybe not super fast but if you only need to do it once on 50 workbooks it should be good enough. Note that the replace line should make the replacement in all the sheets of the workbook.
Option Explicit
Public Sub replaceLinks()
Dim path As String
Dim file As String
Dim w As Workbook
Dim s As Worksheet
On Error GoTo error_handler
path = "C:\Users\xxxxxx\Documents\Test\"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
file = Dir$(path & "*.xlsx", vbNormal)
Do Until LenB(file) = 0
Set w = Workbooks.Open(path & file)
ActiveSheet.Cells.Replace What:="'THE_LINK_YOU_WANT_TO_CHANGE'!", _
Replacement:="'THE_NEW_LINK'!", LookAt:=xlPart
w.Save
w.Close
file = Dir$
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
error_handler:
MsgBox Err.Description
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
You can do this in Excel 2010 without using any code. (If memory serves, it will also work in earlier versions of Excel.)
Open all 50 ancillary excel files in Excel at the same time.
Open BigList.xlsx. (You now have 51 files open in Excel.)
Click File - Save As and save BigList as MasterDatabase.xlsm
Close the new MasterDatabase.xlsm file.
Look at one of the ancillary files and verify that Excel has it pointed to the new file.
Close and save all files.
This code will automate the link change directly
Update your paths to BigList.xlsx and MasterDatabase.xlsm in the code
Update your path to the 40-50 files (I have used c:\temp\")
The code will then open both these files (for quicker relinking), then one by open the files in strFilePath, change the link from WB1 (strOldMasterFile ) to Wb2 (strOldMasterFile ), then close the saved file
Please note it assumes all these files are closed on code start, as the code will open these file
Sub ChangeLinks()
Dim strFilePath As String
Dim strFileName As String
Dim strOldMasterFile As String
Dim strNewMasterFile As String
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim WB3 As Workbook
Dim lngCalc As Long
strOldMasterFile = "c:\testFolder\bigList.xlsx"
strNewMasterFile = "c:\testFolder\newFile.xlsm"
On Error Resume Next
Set WB1 = Workbooks.Open(strOldMasterFile)
Set WB2 = Workbooks.Open(strNewMasterFile)
If WB1 Is Nothing Or WB2 Is Nothing Then
MsgBox "One (or both) of " & vbnerwline & strOldMasterFile & vbNewLine & strNewMasterFile & vbNewLine & "cannot be found"
WB1.Close False
WB2.Close False
Exit Sub
End If
On Error GoTo 0
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With
strFilePath = "c:\temp\"
strFileName = Dir(strFilePath & "*.xls*")
'Error handling as link may not exist in all files
On Error Resume Next
Do While Len(strFileName) > 0
Set WB2 = Workbooks.Open(strFilePath & strFileName, False)
WB2.ChangeLink strOldMasterFile, strNewMasterFile, xlExcelLinks
WB2.Save
WB2.Close False
strFileName = Dir
Loop
On Error GoTo 0
WB1.Close False
WB2.Close False
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
End With
End Sub