Word Macro For Saving Files With Variable Default Name According to Text Value in Heading 1

zanodor · #1 07-01-2022, 05:36 AM

I am new to macros so I was hunting around for procedures on the internet trying to find solutions as to how to carry out various automations for large Word documents. Thank goodness, I am now 2/3 of the way done.

The remaining task is the following:
In a folder containing all my files, split all Word documents by Section Breaks and name the new files according to the text value in the first line of Heading 1 up to the unit-ending dot.
In my case, this unit can be one character, two, three, even 4-5 words (when I was at a loss how to name somthing), complete with diacritics (my texts are bilingual). Example:

The key is to cover everything up to the dot. All titles of these entries have a dot at the end.
If the solution can only work with dashes ("-") or underscore characters ("_") between words, I can live with that. Especially because these documents will have to be converted to MD files and I don't know how PanDoc will handle my files.
But spaces between words and the unicode use of all accented words would be best. I could probable use a universal batch rename software to alter my filenames later, should the need arise.
Some titles that deal with so-called etymons are all capitals, so I'd need those intact as well, if possible.

I have various codes of VBA that I was using, so here is an example. If someone could append this with the modification, that would be perfect:

Code:

Sub SaveEachSectionAsADoc()
  Dim objDocAdded As Document
  Dim objDoc As Document
  Dim nSectionNum As Integer
  Dim strFolder As String

  Dim dlgFile As FileDialog
 
  ' Initialization
  Set objDoc = ActiveDocument
 
  Set dlgFile = Application.FileDialog(msoFileDialogFolderPicker)
 
  ' Pick a location to keep new files.
  With dlgFile
    If .Show = -1 Then
      strFolder = .SelectedItems(1) & "\"
    Else
      MsgBox "Select a folder first!"
      Exit Sub
    End If
  End With
 
  ' Step through each section in current document, copy and paste each to a new one.
  For nSectionNum = 1 To ActiveDocument.Sections.Count
    Selection.GoTo What:=wdGoToSection, Which:=wdGoToNext, Name:=nSectionNum
    ActiveDocument.Sections(nSectionNum).Range.Copy
 
    Set objDocAdded = Documents.Add
    Selection.Paste
 
    ' Save and close new documents.
    objDocAdded.SaveAs FileName:=strFolder & "Section " & nSectionNum & ".docx"
    objDocAdded.Close
  Next nSectionNum
End Sub

I would need a code that batch handles all files in a folder, with two sets of loops: one to handle all sections within a file (as in the code above) and one to go through all files in a folder.

If there is absolutely no way to implement this, maybe there is another way: the headings to be used as filenames are always bold and underlined. That is the unit/value to be used. Whatever comes after the delimiter dot (usually in the same line) is not to be taken to account.
If there is no parameter/expression to achieve that, a code which saves files based on the first 3 words in Heading 1 would suffice (in that case, the dot would also be present in many instances, of course).

Any help is greatly appreciated.
Thanks in advance,

Zan

zanodor · #2 07-01-2022, 11:19 AM

Quote:

Originally Posted by zanodor

I am new to macros so I was hunting around for procedures on the internet trying to find solutions as to how to carry out various automations for large Word documents. Thank goodness, I am now 2/3 of the way done.

The remaining task is the following:
In a folder containing all my files, split all Word documents by Section Breaks and name the new files according to the text value in the first line of Heading 1 up to the unit-ending dot.
In my case, this unit can be one character, two, three, even 4-5 words (when I was at a loss how to name somthing), complete with diacritics (my texts are bilingual).

The key is to cover everything up to the dot. All titles of these entries have a dot at the end.
If the solution can only work with dashes ("-") or underscore characters ("_") between words, I can live with that. Especially because these documents will have to be converted to MD files and I don't know how PanDoc will handle my files.
But spaces between words and the unicode use of all accented words would be best. I could probable use a universal batch rename software to alter my filenames later, should the need arise.
Some titles that deal with so-called etymons are all capitals, so I'd need those intact as well, if possible.

I have various codes of VBA that I was using, so here is an example. If someone could append this with the modification, that would be perfect:

Code:

Sub SaveEachSectionAsADoc()
  Dim objDocAdded As Document
  Dim objDoc As Document
  Dim nSectionNum As Integer
  Dim strFolder As String

  Dim dlgFile As FileDialog
 
  ' Initialization
  Set objDoc = ActiveDocument
 
  Set dlgFile = Application.FileDialog(msoFileDialogFolderPicker)
 
  ' Pick a location to keep new files.
  With dlgFile
    If .Show = -1 Then
      strFolder = .SelectedItems(1) & "\"
    Else
      MsgBox "Select a folder first!"
      Exit Sub
    End If
  End With
 
  ' Step through each section in current document, copy and paste each to a new one.
  For nSectionNum = 1 To ActiveDocument.Sections.Count
    Selection.GoTo What:=wdGoToSection, Which:=wdGoToNext, Name:=nSectionNum
    ActiveDocument.Sections(nSectionNum).Range.Copy
 
    Set objDocAdded = Documents.Add
    Selection.Paste
 
    ' Save and close new documents.
    objDocAdded.SaveAs FileName:=strFolder & "Section " & nSectionNum & ".docx"
    objDocAdded.Close
  Next nSectionNum
End Sub

I would need a code that batch handles all files in a folder, with two sets of loops: one to handle all sections within a file (as in the code above) and one to go through all files in a folder.

If there is absolutely no way to implement this, maybe there is another way: the headings to be used as filenames are always bold and underlined. That is the unit/value to be used. Whatever comes after the delimiter dot (usually in the same line) is not to be taken to account.
If there is no parameter/expression to achieve that, a code which saves files based on the first 3 words in Heading 1 would suffice (in that case, the dot would also be present in many instances, of course).

Any help is greatly appreciated.
Thanks in advance,

Zan

I managed to merge two codes found online. It works (on one file only at a time) with occasional errors in file names:

Code:

Sub Modified_SaveEachSectionAsADoc()
      Dim objDocAdded As Document
      Dim objDoc As Document
      Dim nSectionNum As Integer
      Dim strFolder As String
    
      Dim dlgFile As FileDialog
    
      Set objDoc = ActiveDocument
     
      Set dlgFile = Application.FileDialog(msoFileDialogFolderPicker)

      With dlgFile
        If .Show = -1 Then
          strFolder = .SelectedItems(1) & "\"
        Else
          MsgBox "Select a folder first!"
          Exit Sub
        End If
      End With
     
      For nSectionNum = 1 To ActiveDocument.Sections.Count
        Selection.GoTo What:=wdGoToSection, Which:=wdGoToNext, Name:=nSectionNum
        ActiveDocument.Sections(nSectionNum).Range.Copy
     
        Set objDocAdded = Documents.Add
        Selection.Paste
     
      Dim strFileName As String
    Set rngFilename = objDocAdded.Range
    With rngFilename
        .End = .Start
        .MoveEnd wdWord, 3
        strFileName = .Text
    End With
    objDocAdded.SaveAs "B:\Wordcopy Sections\" & strFileName & ".docx"
        objDocAdded.Close
      Next nSectionNum
    End Sub

I was trying to fit the following in there and played around with it for a while but could not find the best position (sometimes it was ignored completely, other times had problems with finding Next nSectumNum):

Code:

Do While Len(Filename)
LastDot = InStrRev(Filename, ".")
NewFilename = LEFT(Filename,Len(Filename)-1)
' Name Path & Filename As Path & NewFilename
Filename = Dir()
Loop

It was error 5487 and 5152 on file names not being proper, possibly because the Text String ended on a forbidden character like ":". I am surprised that the dots mentioned above get saved.
A code that makes things go forward after any error message comes up would be nice here too. I could tackle the odd issues afterward one by one.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Saving all clipboard data (text, images & formatting) to a variable	alex100	Word VBA	0	09-03-2020 04:53 AM
Microsoft notepad over word for saving important text files	Noclip1	Word	1	10-25-2017 10:55 PM
Macro to hide/unhide text to call variable bookmarks	Dr. Z	Word VBA	2	05-27-2017 08:20 PM
Saving Excel files as text	martinlest	Excel	4	06-20-2012 06:21 AM
Saving Word files as PDF	catbags	Word	2	03-20-2009 12:42 PM