Skip to content

Instantly share code, notes, and snippets.

@dlaxar

dlaxar/README.md

Created Apr 15, 2020
Embed
What would you like to do?
Mail Merge to Individual files PDF Macro Word/Office 365
  1. Open file and save as .doc
  2. Do your Mail Merge stuff
  3. Create a new Macro (Tools > Macro > Macro) with name 'toindivid'
  4. Paste the contents of the file macro.vba
  5. Change where needed
Sub toindivid()
'
' toindivid Macro
'
'
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 326
' ^
' CHANGE HERE
' TO NUM OF ENTRIES
'
'
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("ID")) = "" Then Exit For
' ^ Sanity check
' CHANGE HERE
' Filename .
'
StrName = .DataFields("ID")
End With
.Execute Pause:=False
If Err.Number = 5631 Then
Err.Clear
GoTo NextRecord
End If
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
With ActiveDocument
'
' CHANGE HERE
' If you want to save it as .docx or .pdf
'
' .SaveAs2 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
Sub toindivid()
'
' toindivid Macro
'
'
' 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 5
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Nachname")) = "" Then Exit For
'StrFolder = .DataFields("Folder") & "\"
StrName = .DataFields("Nachname") & "_" & .DataFields("Vorname")
End With
.Execute Pause:=False
If Err.Number = 5631 Then
Err.Clear
GoTo NextRecord
End If
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
.SaveAs2 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment