Merge several Word files, using filename as Heading1, and demoted (embedded) headers-CodePudding

I have a few hundred Word docx files, which I'd like to merge into a single docx file.

Each of these files has headers that are formatted using Heading1, Heading2,.. styles, all of which are likely the same across the files, in terms of style formatting.

I'd like each file's content to be included in a Heading1 header named for the file's name. The document's headers should be demoted -1 inside of that, such that the document's own Heading1's become Heading2's, etc.

This task is complex enough that no GUI solution probably exists (Insert|Text|Object|TextFromFile only does a simple merge), and might be too complex for VBA also. It's also similar (but not similar enough) to others I found forum theads for, while searching for solutions online (example).

Finally, a compromise solution might be using all these docs as subdocuments in a master document (as explained here), however I found this cumbersome. ACtualy merging them, as per the above, would be preferrable.

CodePudding user response：

I'm not sure what you are referring to with the heading thing, but this code will copy everything from multiple word files in a folder, and paste it into a single word file. Once everything is consolidated in a single file, you can do whatever you want with it, like formatting headers.

Sub Foo() 
Dim i As Long 
Application.ScreenUpdating = False 
Documents.Add 
With Application.FileSearch 
  'Search in foldername 
  .LookIn = "C:\test" 
  .SearchSubFolders = False 
  .FileName = "*.doc" 
  .Execute 
    For i = 1 To .FoundFiles.Count 
       If InStr(.FoundFiles(i), "~") = 0 Then 
         Selection.InsertFile FileName:=(.FoundFiles(i)), _ 
         ConfirmConversions:=False, Link:=False, Attachment:=False 
         Selection.InsertBreak Type:=wdPageBreak 
       End If 
     Next i 
End With 
End Sub

CodePudding user response：

You can use this code to "downsize" the headings-styles

Public Sub downsizeHeadingHierarchy(doc As Word.Document)


'reset find object
With doc.Range.Find
    .Text = ""
    .Replacement.Text = ""
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
End With


Dim styleEnumFind As Long

'wdStyleHeading1 = -2, wdStyleHeading2 = -3 etc
For styleEnumFind = wdStyleHeading8 To wdStyleHeading1
    With doc.Range.Find
        .Style = ThisDocument.Styles(styleEnumFind)
        'e.g. styleEnumFind = -2 --> replace = -2 - 1 = -3
        .Replacement.Style = ThisDocument.Styles(styleEnumFind - 1) 'replace with next hierarchy
        .Execute Replace:=wdReplaceAll
    End With
Next

End Sub