CODEWITHSUNDEEP
vbams-word
Cocoberry2526
Cocoberry2526

Reputation: 187

MS Word VBA: Saving a document using the header

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.

Upvotes: 0

Views: 886

Answers (2)

Cocoberry2526
Cocoberry2526

Reputation: 187

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

Upvotes: 0

Variatus
Variatus

Reputation: 14373

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

Upvotes: 1

Related Questions