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.

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

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