I'm trying to use a macro I found online to save each doc from a mail merge into an individual PDF. But the macro does nothing. (never used macros before or VB) I tried stepping through the code and I get .DataSource.RecordCount = -1.
I can see the previewed documents, so the datasource is there. I figure there is something wrong with how it's getting the count value.
Any help is appreciated.
This is the whole macro:
Sub Merge_To_Individual_Files()
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Set MainDoc = ActiveDocument
With MainDoc
StrFolder = .Path & "\"
With .MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
On Error Resume Next
For i = 1 To .DataSource.RecordCount
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Last_Name")) = "" Then Exit For
'StrFolder = .DataFields("Folder") & "\"
StrName = .DataFields("key")
End With
On Error GoTo NextRecord
.Execute Pause:=False
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
With ActiveDocument
'Add the name to the footer
'.Sections(1).Footers(wdHeaderFooterPrimary).Range.InsertBefore StrName
.SaveAs FileName:=StrFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
.SaveAs FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
NextRecord:
Next i
End With
End With
Application.ScreenUpdating = True
End Sub
Related
So I have been trying to use a the below macro to split a mail-merged document into individual documents. When I run the macro, I receive "Runtime Error '5852' Requested object is not available." The issue is highlighted as .Destination = wdSendToNewDocumentwhen using the debug action.
I though that perhaps the issue was with the file being located on my OneDrive but after moving the files to a local drive, I recieved the same issue. Any insight into how to resolve this error would be helpful.
If more info is necessary, please let me know and I would be happy to answer as best I could.
Code for reference:
Sub MailMergeToDoc()
'
' MailMergeToDoc Macro
' Collects the results of the mail merge in a document
'
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Set MainDoc = ActiveDocument
With MainDoc
StrFolder = .Path & "\"
With .MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
On Error Resume Next
For i = 1 To .DataSource.RecordCount
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Last_Name")) = "" Then Exit For
'StrFolder = .DataFields("Folder") & "\"
StrName = .DataFields("Last_Name") & "_" & .DataFields("First_Name")
End With
On Error GoTo NextRecord
.Execute Pause:=False
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
With ActiveDocument
'Add the name to the footer
'.Sections(1).Footers(wdHeaderFooterPrimary).Range.InsertBefore StrName
.SaveAs FileName:=StrFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
.SaveAs2 FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
NextRecord:
Next i
End With
End With
Application.ScreenUpdating = True
End Sub
This is pretty basic troubleshooting. You can't just copy code without understanding what it's doing.
Your MailMerge object does not exist when you're trying to run the mail merge.
You need to create a Mail Merge first in your Word doc - just use the Wizard - and that object will be magically filled. Then you'll have to progress to your next error.
This is code derived from Mail Merge Tips and Tricks.
Sub Merge_To_Individual_Files()
Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
Set MainDoc = ActiveDocument
With MainDoc
StrFolder = .Path & Application.PathSeparator
For i = 1 To .MailMerge.DataSource.RecordCount
With .MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Name")) = "" Then Exit For
StrName = .DataFields("Number") & "_" & .DataFields("Name") & "_Test"
End With
.Execute Pause:=False
End With
StrName = Trim(StrName)
With ActiveDocument
.SaveAs2 FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.PrintOut Copies:=1
.Close SaveChanges:=False
End With
Next i
End With
Application.ScreenUpdating = True
End Sub
The code separates a serial letter into individual files, saves them as pdf and starts the printing.
The macro saves all the files in the same folder and I have to move each file to the designated folder manually (each file has an own folder with the "Number" from the code as its name).
Is it possible to save the files directly in the intended folder?
I'd do something like this:
Dim num, numGen as long, f, StrFolder As String
'...
'...
num = .DataFields("Number") 'capture the value in the With .DataSource block
'...
'...
'check if the destination folder exists
f = FindFolder(StrFolder, CStr(num)) 'returns folder path if exists
If Len(f) = 0 Then
'no match was found - use a generic folder
f = StrFolder & "General" 'or whatever you want
numGen = numGen + 1
End If
.SaveAs2 FileName:= f & _
Application.PathSeparator & StrName & ".pdf", _
FileFormat:=wdFormatPDF, AddToRecentFiles:=False
'...
'...
'Notify that some files need to be moved
If numGen > 0 Then
Msgbox numGen & " files were saved to 'General' folder"
End If
This function will return the path of any matched folder given a starting folder to begin in (includes searching in subfolders). Returns empty string if no match.
Function FindFolder(StartAt As String, ByVal folderName As String) As String
Dim colFolders As New Collection, sf, path, fld, fso
Set fso = CreateObject("scripting.filesystemobject")
colFolders.Add StartAt
Do While colFolders.Count > 0
fld = colFolders(1)
colFolders.Remove 1
If Right(fld, 1) <> "\" Then fld = fld & "\"
For Each sf In fso.getfolder(fld).subfolders
If sf.Name = folderName Then
FindFolder = sf.path
Exit Function
Else
colFolders.Add sf
End If
Next sf
Loop
End Function
Your code is derived from the Send Mailmerge Output to Individual Files article in the Mailmerge Tips & Tricks thread, at https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html.
That article contains code for setting the save path and tells you how to use it...
I am trying to change the contents of square brackets into a merge field. I've got 80-ish documents to go through some with none square brackets and some with a few (none nested).
I have managed to run my code and it has worked for some files. Others (majority) have given an overflow error. When I examined what was happening in one of the files, the code picks up the contents correctly, it just puts the merge field in the wrong place which in turn causes it to keep finding the same set of square brackets.
Public Function searchFiles(fFile As Variant, rootFolderStr2 As String, rootFolderStr As String)
Dim strTemp As String, mfc As String, msg As String
Dim startStr As Integer, endStr As Integer
Dim objWord As New Word.Application
Dim objDoc As Word.Document
Dim aField As Field, fFolder As String
Dim rng As Variant, myField As Field, oldField As Variant
On Error GoTo ErrorHandler
'open file
'Open fFile For Input As #1
Set objDoc = objWord.Documents.Open(fFile)
objDoc.TrackRevisions = False
strTemp = objDoc.Range(0, objDoc.Range.End)
startStr = InStrRev(strTemp, "[")
endStr = InStrRev(strTemp, "]")
Do While startStr <> 0
'Merge field contents
mfc = Right(Left(strTemp, endStr - 1), endStr - startStr - 1)
Set rng = objDoc.Range(startStr - 1, endStr)
Set myField = objDoc.Fields.Add(Range:=rng, Type:=wdFieldMergeField, Text:=mfc)
strTemp = objDoc.Range(0, objDoc.Range.End)
'Find next merge field
startStr = InStrRev(strTemp, "[")
endStr = InStrRev(strTemp, "]")
If endStr < startStr And endStr <> -1 Then
msg = "Error occured in " & fileName & " " & startStr & " " & endStr
Debug.Print (msg)
startStr = 0
endStr = 0
End If
Loop
'put in right folder
fFolder = Right(objDoc.FullName, Len(objDoc.FullName) - Len(rootFolderStr))
objDoc.SaveAs fileName:=rootFolderStr2 & "\" & fFolder
objDoc.Close
objWord.Quit
ErrorHandler:
If Err.Number <> 0 Then
Debug.Print ("Error occured in file: " & fileName & " " & Err.Description)
Exit Function
End If
End Function
I'm struggling to understand how the objects in word work so forgive, please.
Any answers as to what's causing this problem would be appreciated or any help with methods to do this in a better manner.
Try:
Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
If strFolder & "\" & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
Call MakeFields(wdDoc)
wdDoc.Close SaveChanges:=True
End If
strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Sub MakeFields(wdDoc As Document)
With wdDoc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = False
.Wrap = wdFindStop
.MatchWildcards = True
.Text = "\[*\]"
.Execute
End With
Do While .Find.Found
.Characters.First.Text = vbNullString
.Characters.Last.Text = vbNullString
.Fields.Add Range:=.Duplicate, Type:=wdFieldEmpty, Text:="MERGEFIELD " & .Text, Preserveformatting:=False
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End Sub
The above code processes all documents in the selected folder.
OK. The generic advice is to always, always, always put option explicit as the start of your module or class. This helps highlights errors in your code related misuse of syntax and undeclared variables etc. In your posted code there is one undeclared variable 'Filename'.
When working with Word it is always better to try to find a way of working with the word object model rather than extracting text.
You can modify your existing code by replacing the instrrev with the .MoveStart/EndUntil methods.
I've updated your code to use these move methods.
If you don't understand what a keyword does then place your cursor on it and press F1. This will take you to the MS help page. For the Word object model the help pages need careful reading.
Option Explicit
' Changed to sub as you are not returning any values
Public Sub searchFiles(fFile As Variant, rootFolderStr2 As String, rootFolderStr As String)
Const FieldOpen As String = "["
Const FieldClose As String = "]"
Dim strTemp As String, mfc As String, msg As String
Dim objWord As New Word.Application
Dim objDoc As Word.Document
' Dim aField As FieldDim
Dim fFolder As String
' Dim rng As Variant
' Dim myField As Field
' Dim oldField As Variant
' Not previously declared
Dim Filename As String
Dim SearchRng As Word.Range
Dim FieldRng As Word.Range
Dim Moved As Long
'open file
'Open fFile For Input As #1
On Error GoTo ErrorHandler
Set objDoc = objWord.Documents.Open(fFile)
objDoc.TrackRevisions = False
'strTemp = objDoc.Range(0, objDoc.Range.End)
Set SearchRng = ActiveDocument.Content
'startStr = InStrRev(strTemp, "[")
Moved = SearchRng.MoveStartUntil(cset:=FieldOpen)
'Do While startStr <> 0
Do Until Moved = 0
'Merge field contents
'mfc = Right(Left(strTemp, endStr - 1), endStr - startStr - 1)
FieldRng.Start = SearchRng.Start + 1
'endStr = InStrRev(strTemp, "]")
' exit if we don't find a closing field marker
' The side effect (which we want) is that the end is also moved
If SearchRng.MoveEndUntil(cset:=FieldClose) = 0 Then GoTo ErrorHandler
FieldRng.End = SearchRng.End + 1
' reduce the FieldRng to just the text
FieldRng.Characters.First.Delete
FieldRng.Characters.Last.Delete
'Set rng = objDoc.Range(startStr - 1, endStr
'Set myField = objDoc.Fields.Add(Range:=rng, Type:=wdFieldMergeField, Text:=mfc)
objDoc.Fields.Add Range:=FieldRng, Type:=wdFieldMergeField, Text:=FieldRng.Text
'strTemp = objDoc.Range(0, objDoc.Range.End)
' We now need to move the start of the search range to after the mergefield
SearchRng.Start = FieldRng.End + 1
'Find next merge field
'startStr = InStrRev(strTemp, "[")
'endStr = InStrRev(strTemp, "]")
Moved = SearchRng.MoveStartUntil(cset:=FieldOpen)
' If endStr < startStr And endStr <> -1 Then
' msg = "Error occured in " & Filename & " " & startStr & " " & endStr
' Debug.Print (msg)
' startStr = 0
' endStr = 0
' End If
Loop
'put in right folder
fFolder = Right(objDoc.FullName, Len(objDoc.FullName) - Len(rootFolderStr))
objDoc.SaveAs Filename:=rootFolderStr2 & "\" & fFolder
objDoc.Close
objWord.Quit
ErrorHandler:
If Err.Number <> 0 Then
Debug.Print ("Error occured in file: " & Filename & " " & Err.Description)
Exit Sub
End If
End Sub
The code above compiles without error but I haven't testing the logic. I'll leave that as 'an exercise for the reader'
i currently have 6 mail merge templates that i execute via the following vbs.
this opens each file in the root folder and runs the mailmerge,
VBS
Set fs = CreateObject("Scripting.FileSystemObject")
Set rootFolder = fs.GetFolder(fs.GetParentFolderName(wscript.ScriptFullName))
Set oWord = Createobject("Word.Application")
oWord.Visible = False
For Each file in rootFolder.Files
If LCase(fs.GetExtensionName(file.Name)) = "docx" Then
Set oDocument = oWord.Documents.Open(file.path)
oWord.Run "regular_mail"
oDocument.Close(False)
Set oDocument = Nothing
End If
Next
oWord.Quit
set oWord = nothing
the vba inside word, does the mailmerge puts it in the designated folder, what i get is an error when the datasource for that file has no data. since StrName = .DataFields("pk") wont have any values.
Where im stuck is how to go around that error, or check whether the data source is blank then move on to the next template.
each template should save to one file so my mailroom can print.
VBA in word:
Sub regular_mail()
Dim sDate As String, StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long, fso As Object, StrMonthPath As String, StrDayPath As String, StrFileName As String
sDate = Format(Now(), "mmddyy")
Const StrFolderName As String = "C:\Test\Files\"
Set fso = CreateObject("Scripting.FileSystemObject")
With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
StrName = .DataFields("pk")
StrMonthPath = .DataFields("month_path")
StrDayPath = .DataFields("day_path")
StrSendDate = .DataFields("send_date")
StrFileName = sDate & "_" & fso.GetBaseName(ActiveDocument.Name)
End With
.Execute Pause:=False
'Creates directory if it doesnt exist
If Not fso.FolderExists(StrFolderName & StrMonthPath) Then
fso.CreateFolder (StrFolderName & StrMonthPath)
End If
If Not fso.FolderExists(StrFolderName & StrMonthPath & StrDayPath) Then
fso.CreateFolder (StrFolderName & StrMonthPath & StrDayPath)
End If
If Not fso.FolderExists(StrFolderName & StrMonthPath & StrDayPath & "letters\") Then
fso.CreateFolder (StrFolderName & StrMonthPath & StrDayPath & "letters\")
End If
End With
ActiveDocument.SaveAs2 FileName:=StrFolderName & StrMonthPath & StrDayPath & "letters\" & StrFileName, FileFormat:=16, AddToRecentFiles:=False
ActiveWindow.Close
End Sub
any and all help is appreciated, thank you in advance.
Without being able to test it myself right now, you could use both or one of these approaches:
You could check it DataSource is nothing (or if is not Nothing, as you need):
If .DataSource Is Nothing Then ...
You could check if there are records in the Datasource:
If .DataSource.RecordCount = 0 Then
I have this VBA code to convert CSV to XLSX, which seems to work but output Excel have strange strings like "Aço" and "plástico" instead of "Aço" or "plástico". I think solution is to include "Unicode UTF-8", but I couldn't find a way. Any help would be appreciated.
Sub CSVtoXLSX()
Dim xFd As FileDialog
Dim xSPath As String
Dim xCSVFile As String
Dim xWsheet As String
Application.DisplayAlerts = False
Application.StatusBar = True
xWsheet = ActiveWorkbook.Name
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
xFd.Title = "Select a folder:"
If xFd.Show = -1 Then
xSPath = xFd.SelectedItems(1)
Else
Exit Sub
End If
If Right(xSPath, 1) <> "\" Then xSPath = xSPath + "\"
xCSVFile = Dir(xSPath & "*.csv")
Do While xCSVFile <> ""
Application.StatusBar = "Converting: " & xCSVFile
Workbooks.Open Filename:=xSPath & xCSVFile
ActiveWorkbook.SaveAs Replace(xSPath & xCSVFile, ".csv", ".xlsx", vbTextCompare), xlWorkbookDefault
ActiveWorkbook.Close
Windows(xWsheet).Activate
xCSVFile = Dir
Loop
Application.StatusBar = False
Application.DisplayAlerts = True
End Sub