How to Split Documents in Word

Sub SplitDocumentIntoTenParts()
Dim doc As Document
Set doc = ActiveDocument

Dim totalWords As Long
totalWords = doc.Content.Words.Count

Dim sectionsCount As Long
sectionsCount = 10 ‘ Number of sections to divide the document into

Dim wordsPerSection As Long
wordsPerSection = totalWords \ sectionsCount ‘ Calculate words per section

Dim startWordIndex As Long
startWordIndex = 1

Dim folderPath As String
folderPath = “/Users/ggreen/Desktop/Split_Documents/”

‘ Ensure directory accessibility with a test file
Dim createTestFileScript As String
createTestFileScript = “do shell script “”echo ‘Test file creation successful.’ > ” & folderPath & “testfile.txt”””

On Error GoTo ErrorHandler
MacScript (createTestFileScript)

If Dir(folderPath & “testfile.txt”) = “” Then
MsgBox “The directory does not exist or cannot be accessed: ” & folderPath
Exit Sub
Else
‘ Clean up by deleting the test file
Kill folderPath & “testfile.txt”
End If

Dim i As Long
For i = 1 To sectionsCount
Dim newDoc As Document
Set newDoc = Documents.Add

‘ Determine the range for this section
Dim endWordIndex As Long
If i = sectionsCount Then
endWordIndex = totalWords
Else
endWordIndex = startWordIndex + wordsPerSection – 1
End If

Dim rng As Range
Set rng = doc.Range(Start:=doc.Words(startWordIndex).Start, End:=doc.Words(endWordIndex).End)
rng.Copy
newDoc.Content.Paste

‘ Save new document
Dim filePath As String
filePath = folderPath & “section” & i & “.docx”
newDoc.SaveAs2 FileName:=filePath, FileFormat:=wdFormatDocumentDefault
newDoc.Close

‘ Update start word index for the next section
startWordIndex = endWordIndex + 1
Next i

Exit Sub

ErrorHandler:
MsgBox “An error occurred: ” & Err.Description
End Sub

This is for macOS computers.

Views: 0