MS Word VBA: Saving a document using the header - vba

Question

I have been trying to figure out a way to, after performing a mail merge, separate the documents into individual ones and name them after a specific item, preferably the first line of the header. I have only been able to find ways to split the document, but cannot figure out how to name it. Any help with how to write the VBA code to save a document as the header would be very much appreciated.

Answer 1

Since you already separated the documents, the code below might give them names using their first sentence.
Private Function DocName(Doc As Document) As String
' 23 Aug 2017
Const Illegals As String = "\:/;?*|>"""
Static FaultCounter As Integer
Dim Fun As String
Dim Title As String
Dim Ch As String
Dim i As Integer
Title = Trim(Doc.Sentences(1))
For i = 1 To Len(Title)
Ch = Mid(Title, i, 1)
If (Asc(Ch) > 31) And (Asc(Ch) < 129) Then
If InStr(Illegals, Ch) = 0 Then Fun = Fun & Ch
End If
Next i
If Len(Fun) = 0 Then
FaultCounter = FaultCounter + 1
Fun = Format(FaultCounter, """Default File Name (""0"")""")
End If
DocName = Fun
End Function
Before saving the file you might want to check for duplicates. Use the Dir() function for that and add a number to duplicate names using the system I included above to name files where the first sentence might be empty.
You may also have to review the characters which aren't permitted in file names. I have simply excluded all below ASCII(32) and above ASCII(128), and then the known ones Windows doesn't like. You might want to modify that range further.
To call the above function use code like this:-
Private Sub GetName()
Debug.Print DocName(ActiveDocument)
End Sub

Answer 2

This is the code I have so far, I was able to find it off of a very helpful website, but the code saves as the word "report" which I set it to right now while I'm trying to figure it out, and then the number of the document.
Option Explicit
Sub splitter()
' splitter Macro
' Macro created by Doug Robbins to save each letter created by a mailmergeas
a separate file.
Application.ScreenUpdating = False
Dim Program As String
Dim DocName As String
Dim Letters As Integer, Counter As Integer
Letters = ActiveDocument.Sections.Count
Selection.HomeKey Unit:=wdStory
Counter = 1
While Counter < Letters
'program = ActiveDocument.MailMerge.DataSource.DataFields("Program_Outcomes_PlanReport_Name").Value
DocName = "Reports" & LTrim$(Str$(Counter)) 'Generic name of document
ActiveDocument.Sections.First.Range.Cut
Documents.Add
Selection.Paste
ActiveDocument.Sections(2).PageSetup.SectionStart = wdSectionContinuous
ActiveDocument.SaveAs filename:="E:\assessment rubrics\Templates" & "\" & DocName, FileFormat:=wdFormatDocument, LockComments:=False, Password:="",
AddToRecentFiles:=False, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False
ActiveWindow.Close
Counter = Counter + 1
Wend
Application.ScreenUpdating = True
End Sub