Word Doc Split

[JonathanWalsh2]

Hi Everyone,

 

Looking to split a word document using the header1 feature. However I can’t use the split that built into work due to the document having tables in it. So I went down the vba route. However I keep getting errors. I’m wanting to split via header 1 tag and then use the text in header 1 as the file name.

 

Whats wrong with my code?

 

Thanks in advance

 

Sub SplitDocumentByHeading1()

Dim originalDoc As Document

Dim newDoc As Document

Dim para As Paragraph

Dim rng As Range

Dim title As String

Dim saveFolderPath As String

 

' Set the folder path to save the new documents

saveFolderPath = "\\SAM-FS-02\staffhome$\jwalsh\MCAS"

 

' Set the original document

Set originalDoc = ActiveDocument

 

' Loop through each paragraph in the document

For Each para In originalDoc.Paragraphs

' Check if the paragraph is a Heading 1

If para.Style = "Heading 1" Then

' Get the Heading 1 text as the document title

title = para.Range.Text

 

' Create a new document

Set newDoc = Documents.Add

newDoc.Range.FormattedText = para.Range.FormattedText

 

' Set the range to include the entire new document

Set rng = newDoc.Range

 

' Find and remove the page breaks in the new document

With rng.Find

.Text = "^m"

.Replacement.Text = ""

.Forward = True

.Wrap = wdFindContinue

.Execute Replace:=wdReplaceAll

End With

 

' Save and close the new document in the specified folder with the title as the file name

newDoc.SaveAs2 saveFolderPath & title & ".docx"

newDoc.Close

 

' Reset the range to the original document

Set rng = originalDoc.Range

End If

Next para

 

' Clean up objects

Set newDoc = Nothing

Set originalDoc = Nothing

 

' Notify the user when the splitting process is complete

MsgBox "Document has been split by Heading 1."

End Sub

[TheRobins]

I wonder if this can help, its great, use it quite a bit.

 

Merge and Split

[JonathanWalsh2]

I have that already but I don’t have a csv file with it. I spent about 8hrs on it last night trying vba and also Python but I think the document has all sorts of tables embedded. The link you sent also has a split function program but you can’t use the header 1 text as the file name and they are all random numbers

[pfl]

Please can you try the following (the below worked for me, When the save dialog failed I noticed it was passing the vbcr in the filename - below gets rid of it, also you were missing the trailing '\' in your folder path)

Note - All this does is split the document at the Paragraph 1 formating, saves it as a new document with the paragraph 1 filename including the paragraph 1 text in the newly saved split document):

 

Sub SplitDocumentByHeading1()

Dim originalDoc As Document

Dim newDoc As Document

Dim para As Paragraph

Dim rng As Range

Dim title As String

Dim saveFolderPath As String

 

 

 

' Set the folder path to save the new documents

saveFolderPath = "\\SAM-FS-02\staffhome$\jwalsh\MCAS\"

' Set the original document

Set originalDoc = ActiveDocument

 

' Loop through each paragraph in the document

For Each para In originalDoc.Paragraphs

' Check if the paragraph is a Heading 1

If para.Style = "Heading 1" Then

' Get the Heading 1 text as the document title

 

' Create a new document

Set newDoc = Documents.Add

newDoc.Range.FormattedText = para.Range.FormattedText

 

' Set the range to include the entire new document

Set rng = newDoc.Range

 

' Find and remove the page breaks in the new document

With rng.Find

.Text = "^m"

.Replacement.Text = ""

.Forward = True

.Wrap = wdFindContinue

.Execute Replace:=wdReplaceAll

End With

 

' Save and close the new document in the specified folder with the title as the file name

title = Split(para.Range.Text, vbCr)(0)

For i = 1 To Len(StrNoChr)

title = Replace(title, Mid(StrNoChr, i, 1), "_")

Next

title = title & ".docx"

newDoc.SaveAs2 saveFolderPath & title, FileFormat:=wdFormatDocumentDefault

newDoc.Close

 

' Reset the range to the original document

Set rng = originalDoc.Range

End If

Next para

 

' Clean up objects

Set newDoc = Nothing

Set originalDoc = Nothing

 

' Notify the user when the splitting process is complete

MsgBox "Document has been split by Heading 1."

End Sub

Edited June 20, 2023 by pfl

[pfl]

If you want to split the document at every header 1 and use the header as the fileneame but also want to include the table under each header 1, use the following (This has been tested with a simple table & header 1 text):

 

Sub SplitDocumentByHeading1()

Dim originalDoc As Document

Dim newDoc As Document

Dim para As Paragraph

Dim rng As Range

Dim title As String

Dim saveFolderPath As String

 

 

 

' Set the folder path to save the new documents

saveFolderPath = "\\SAM-FS-02\staffhome$\jwalsh\MCAS\"

' Set the original document

Set originalDoc = ActiveDocument

 

' Loop through each paragraph in the document

For Each para In originalDoc.Paragraphs

' Check if the paragraph is a Heading 1

If para.Style = "Heading 1" Then

' Get the Heading 1 text as the document title

 

 

' Set the header range starting from the paragraph

Set headerRange = para.Range

' Extend the range to include the entire header content

headerRange.Expand Unit:=wdParagraph

Set tableRange = headerRange.Next(wdTable)

' Copy the header range

headerRange.Copy

' Create a new document

Set newDoc = Documents.Add

newDoc.Range.FormattedText = para.Range.FormattedText

' Copy the table range

tableRange.Copy

' Paste the table into the new document

Set newdocrange = ActiveDocument.Content

newdocrange.Collapse Direction:=wdCollapseEnd

newdocrange.Paste

 

 

' Set the range to include the entire new document

Set rng = newDoc.Range

 

' Find and remove the page breaks in the new document

With rng.Find

.Text = "^m"

.Replacement.Text = ""

.Forward = True

.Wrap = wdFindContinue

.Execute Replace:=wdReplaceAll

End With

 

' Save and close the new document in the specified folder with the title as the file name

title = Split(para.Range.Text, vbCr)(0)

For i = 1 To Len(StrNoChr)

title = Replace(title, Mid(StrNoChr, i, 1), "_")

Next

title = title & ".docx"

newDoc.SaveAs2 saveFolderPath & title, FileFormat:=wdFormatDocumentDefault

newDoc.Close

 

' Reset the range to the original document

Set rng = originalDoc.Range

End If

Next para

 

' Clean up objects

Set newDoc = Nothing

Set originalDoc = Nothing

 

' Notify the user when the splitting process is complete

MsgBox "Document has been split by Heading 1."

End Sub

Edited June 21, 2023 by pfl