指定ページ数単位でワード文書を簡単に分割するマクロ【図解】

このマクロは、指定ページ数単位でワード文書を簡単に分割するマクロ（Word VBA）です。

このマクロを実行すると、以下のイラストのように、ワード文書を簡単に複数のワード文書へと分割することができます。

出力される分割ファイルは、デスクトップ上に自動作成されるフォルダ内に格納されます。

\Word VBAを学べる数少ない一冊 ( ´•ᴗ• ´ ) /

マクロの全体の流れ

step
1各自のワード文書を開きます

step
2ワード文書の左上に表示される本マクロのアイコンをクリックします

（アイコンの種類は各自が選べます。詳細は、後述の「マクロの使用準備」をご参照ください）

step
3分割ページ数単位を入力します

現在開いているワード文書を何ページ単位で分割するかを整数（全角でも半角でも可）で入力します。

入力後に「OK」ボタンを押します。

分割単位は、１～最大ページ数－１の範囲で入力してください。

例えば、分割単位を１に設定すると、元のファイルを１ページずつ保存することができます。

以下は、分割単位を５０に設定した場合に表示されるメッセージボックスです。

この場合、ワードファイルは４個（５０ページが３個と２４ページが１個）に分割されます。

よろしければ「はい」を押します。

「はい」を押すと自動で処理が始まり、ワード文書の左下に以下のように進行状況が表示されます。

処理が終了すると、以下のメッセージが表示されます。

分割ファイルは、デスクトップ上に自動で作成されるフォルダの中に入っています。

既に同じ名前のフォルダがデスクトップ上に存在する場合は、上書きは行われず、フォルダ名に枝番が付いた新たなフォルダが自動作成されます。

フォルダ名は、「〇〇.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