このマクロは、指定ページ数単位でワード文書を簡単に分割するマクロ（Word VBA）です。
このマクロを実行すると、以下のイラストのように、ワード文書を簡単に複数のワード文書へと分割することができます。
出力される分割ファイルは、デスクトップ上に自動作成されるフォルダ内に格納されます。
マクロの全体の流れ
step
1各自のワード文書を開きます
step
2ワード文書の左上に表示される本マクロのアイコンをクリックします
（アイコンの種類は各自が選べます。詳細は、後述の「マクロの使用準備」をご参照ください）
step
3分割ページ数単位を入力します
現在開いているワード文書を何ページ単位で分割するかを整数（全角でも半角でも可）で入力します。
入力後に「OK」ボタンを押します。
以下は、単位を50に設定した場合に表示されるメッセージボックスです。
この場合、ワードファイルは4個（50ページが3個と24ページが1個）に分割されます。
よろしければ「はい」を押します。
「はい」を押すと自動で処理が始まり、ワード文書の左下に以下のように進行状況が表示されます。
処理が終了すると、以下のメッセージが表示されます。
分割ファイルは、デスクトップ上に自動で作成されるフォルダの中に入っています。
既に同じ名前のフォルダがデスクトップ上に存在する場合は、上書きは行われず、フォルダ名に枝番が付いた新たなフォルダが自動作成されます。
フォルダ名は、「〇〇.docxの分割ファイル」という形式になります（〇〇は、分割元ワードファイルの名前です）。
分割ファイルの名前は、以下のように「ファイル名_開始ページ-終了ページ」の形式になります。
以上が本マクロの全体の流れです。
このようにとてもシンプルなマクロです。
補足説明
分割失敗メッセージ
分割元のワード文書によっては、以下のメッセージがでる場合があります。
このメッセージは、分割処理が失敗したときに表示されます。
具体的には、分割ページ数単位の境界ページにページをまたぐ表などが存在する場合です。
この場合は、内容を確認後にOKボタンを押してください。
その分割単位をスキップして処理が続行されます。
例えば、２５ページ単位での分割において５０ページ目と５１ページ目をまたいで分割できない表などが存在する場合、
２６～５０ページの単位の出力に失敗し、さらに、５１～７５ページの単位の出力に失敗します。
そのため、上記のメッセージは２回連続で表示されます。
いずれもOKボタンを押してスキップしてください。
上記のメッセージが表示された場合は、該当ページに何が存在するかを確認し、それを手動で分割するか、そうした表などが分割境界にこない分割ページ単位数を設定してください。
分割元ワードファイルの保存について
分割元ワードファイルの変更が保存されていない状態で本マクロを実行すると、以下のメッセージが出ます。
分割元ワードファイルを保存して変更を確定させてから本マクロを実行してください。
分割元ワード文書を開いた時に表示されるメッセージ
本マクロとは無関係に、一般的に、新たに入手／コピーしたワードファイルを開くと、以下のように「編集を有効にする」というボタンが表示される場合があります。
この場合、「編集を有効にする」を押してから、本マクロを実行してください。
本マクロは、分割元ワードファイルを変更するものではありませんが、本マクロが動作するには「編集を有効にする」を押す必要があります。
また、本マクロは分割元ワードファイルを変更するものではありませんが、念のためワードファイルの事前バックアップをお願いします。
マクロの使用準備
以下の手順を行うことで、各自のワードファイルから本マクロを簡単に呼び出せるようになります。
１．こちらの記事に記載したステップ①の手順０～６までを実施した後、ステップ①の手順７で、この記事の最後にあるコードを標準モジュールのＭodule1にコピペします。
２．こちらの記事に記載したステップ①の８から２２を行います
（ステップ①の１１では、以下のマクロ名を選択してから、追加ボタンを押してください）
Project.Module1.SplitDocumentByPages
ステップ①の１１で追加するのは、上記のマクロ名のみです。
（ステップ①の１３では、お好きなアイコンを選んでください）
（ステップ①の２０での保存名は何でもかまいません）
（ステップ①の２２の次に記載されている「動作確認」はスキップしていただいてかまいません）
３．こちらの記事に記載したステップ②を行います
ステップ②を行うことで、このマクロをどのワード文書からも呼び出せるようになります。
（このステップ②を行うと、各自のワードファイルを開いた際に、各自が選んだマクロアイコンがワード文書の左上に表示されるようになります）
以上で、マクロを使用する準備が整いました！
マクロの削除
本マクロが不要になった場合は、こちらの手順でdotmファイルごと削除してください。
マクロのコード
以下は、本マクロのコードです。
上の説明にあるように標準モジュールにコピペしてご使用ください。
（以下のコードをすべて選択して、そのまま貼り付けてください）
現在の公開バージョンは、V01L01（公開日：2024/10/01）です。
Sub SplitDocumentByPages()
'V01L01
Dim totalPages As Long
Dim splitPages As Variant
Dim numFiles As Long
Dim pageCounter As Long
Dim fileCounter As Long
Dim answer As Integer
Dim doc As Document
Dim newDoc As Document
Dim desktopPath As String
Dim folderName As String
Dim baseFolderName As String
Dim filePath As String
Dim fs As Object
Dim i As Integer
Dim docNameWithoutExtension As String
Dim originalDocPath As String
Dim errFlg As Boolean
' 未保存の変更をチェック
If ActiveDocument.Saved = False Then
MsgBox "このドキュメントには未保存の変更があります。" _
& vbCrLf & "保存後に再度処理を実行してください。", vbInformation, "未保存の変更あり"
Exit Sub
End If
' 現在のドキュメントを取得
Set doc = ActiveDocument
originalDocPath = doc.FullName
' 最終ページの取得
totalPages = doc.Content.Information(wdNumberOfPagesInDocument)
' ページ数を入力
splitPages = InputBox(totalPages & "ページのワードファイルを何ページ単位で分割しますか？", "分割ページ数単位の入力")
If VarType(splitPages) = vbString And splitPages = "" Then
Exit Sub
End If
If Not IsNumeric(splitPages) Or splitPages <= 0 Or splitPages >= totalPages Then
MsgBox "1～" & totalPages - 1 & "の有効な整数を入力してください。", vbExclamation
Exit Sub
End If
Application.StatusBar = "処理を開始しました"
splitPages = CLng(splitPages)
' ファイル数を計算
numFiles = totalPages \ splitPages
If totalPages Mod splitPages <> 0 Then numFiles = numFiles + 1
answer = MsgBox(totalPages & "ページのワードファイルを" & numFiles & "個のワードファイルに分割します。" _
& vbCrLf & "よろしいですか？" _
& vbCrLf & "分割ページ数単位：" & splitPages, vbYesNo + vbQuestion, "確認")
If answer = vbNo Then
Exit Sub
End If
' デスクトップパスの取得
desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
' ベースフォルダ名設定
baseFolderName = doc.Name & "の分割ファイル"
' フォルダ名が重複しないように設定
folderName = baseFolderName
fileCounter = 1
Set fs = CreateObject("Scripting.FileSystemObject")
Do While fs.FolderExists(desktopPath & "\" & folderName)
folderName = baseFolderName & "_" & fileCounter
fileCounter = fileCounter + 1
Loop
' フォルダ作成
MkDir (desktopPath & "\" & folderName)
' ドキュメント名から拡張子を除いた部分を取得
docNameWithoutExtension = Left(doc.Name, InStrRev(doc.Name, ".") - 1)
' 最初に分割ファイルの数だけ元のワードファイルのコピーを作成
For i = 1 To numFiles
Dim startPage As Long
Dim endPage As Long
Application.StatusBar = "分割ファイル用のファイル（" & i & "/" & numFiles & "）を準備中です..."
startPage = (i - 1) * splitPages + 1
endPage = IIf(i * splitPages > totalPages, totalPages, i * splitPages)
filePath = desktopPath & "\" & folderName & "\" & _
docNameWithoutExtension & "_" & startPage & "-" & endPage & ".docx"
' 元のドキュメントをコピーして新しいファイルとして保存
doc.SaveAs2 fileName:=filePath, FileFormat:=wdFormatXMLDocument
Next i
' 各分割ファイルを開いて不要な部分を削除してから保存
For fileCounter = 1 To numFiles
Application.StatusBar = "分割ファイル（" & fileCounter & "/" & numFiles & "）を作成中です..."
startPage = (fileCounter - 1) * splitPages + 1
endPage = IIf(fileCounter * splitPages > totalPages, totalPages, fileCounter * splitPages)
filePath = desktopPath & "\" & folderName & "\" & _
docNameWithoutExtension & "_" & startPage & "-" & endPage & ".docx"
' 各保存ファイルを開く
Set newDoc = Documents.Open(filePath)
On Error GoTo ErrorHandler
errFlg = False
' 必要なページ以外を削除
If endPage < totalPages Then
newDoc.Range(newDoc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=endPage + 1).Start, newDoc.Content.End).Delete
End If
If errFlg = False Then
If startPage > 1 Then
newDoc.Range(newDoc.Content.Start, newDoc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=startPage).Start).Delete
End If
End If
If errFlg = False Then
' 変更を保存して閉じる
newDoc.Save
newDoc.Close
End If
On Error GoTo 0
Set newDoc = Nothing
Next fileCounter
Set fs = Nothing
Set doc = Nothing
If Documents.Count = 0 Then
Documents.Open originalDocPath
Else
Documents(originalDocPath).Activate
End If
MsgBox "分割が完了しました。" _
& vbCrLf & "分割ファイルはデスクトップに新規に作成したフォルダの中に入っています。", vbInformation
Application.StatusBar = "分割が完了しました。分割ファイルはデスクトップに新規に作成したフォルダの中に入っています。"
Exit Sub
ErrorHandler:
If Err.Number = 5904 Then
MsgBox "ページ " & startPage & "または" & endPage & "に、ページをまたぐ表が存在します。" & vbNewLine _
& startPage & "～" & endPage & "の分割ファイルの作成に失敗しました。" & vbNewLine _
& "この分割単位をスキップします。" & vbNewLine _
& "このエラーを避けるには、手動で該当表を分割した後に処理を再実行するか、" & vbNewLine _
& "または該当表をまたがないように分割ページ数単位を変更してください。", vbExclamation
On Error Resume Next
newDoc.Close SaveChanges:=wdDoNotSaveChanges
On Error GoTo 0
errFlg = True
Resume Next
Else
MsgBox startPage & "～" & endPage & "の分割ファイルの作成に失敗しました。この分割単位をスキップします" & _
"エラー番号: " & Err.Number & vbNewLine & _
"エラーの説明: " & Err.Description, vbExclamation
On Error Resume Next
newDoc.Close SaveChanges:=wdDoNotSaveChanges
On Error GoTo 0
errFlg = True
Resume Next
End If
End Sub