質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

87.59%

Wordファイルを任意のページ単位でファイル分割したい(VBA使用)

解決済

回答 1

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 2,505

score 7

Wordファイルを任意のページ単位でファイル分割したいと考えています。

例) 15ページから成る1つのwordファイルを、5ページ単位で3ファイルに分割したい。
⇒3ファイル作成(P.1~P.5、P.6~P.10、P.11~P.15)

プログラムを作成しましたが、ファイルによっては、ページ削除時に、ページ位置(ページ内のレイアウト)が崩れてしまい、正しく出力されません。

プログラムの概要
1、元ファイルをコピー(ワークファイル作成)
2、ワークファイルから出力したいページ以外を削除して、残ったページを保存する。
3、ワークファイルを削除
4、1~3の工程を繰り返す。

原因として考えられるのは、ページごとに、余白やフォントが異なること、セクション区切り・ページ区切りが設定されている、など。
※ページ削除処理部分は、わかりやすくコメント行(★)を入れてあります。

開発環境
windows10
Word2016

イメージ説明

Private Sub CommandButton1_Click()


    'オプションボタンが選択されているか
    If OpBtn1 = False And OpBtn2 = False And OpBtn3 = False Then
       MsgBox ("処理を選択してください。")
       Me.OpBtn1.SetFocus
       Exit Sub
    End If


    'テキストボックスに値が入力されているか
    If TextBox1.Text = "" Then
       MsgBox ("ページを指定してください。")
       Me.TextBox1.SetFocus
       Exit Sub
    Else
       TextBox1.Text = Replace(Replace(Replace(Replace(Replace(StrConv(TextBox1.Text, vbNarrow), "、", ","), "―", "-"), "ー", "-"), "~", "-"), "‐", "-")
    End If


    Dim xDoc As Document
    Dim xArr
    Dim w_xarr
    Dim I As Long
    Dim fileName As String
    Dim file_extension As String
    Dim Folder_base As String
    Dim Folder_work As String
    Dim File_base As String
    Dim File_work As String
    Dim Page_base As Integer

  '  Application.ScreenUpdating = False

    'ファイルシステムを扱うオブジェクトを作成
    Set FSO = CreateObject("Scripting.FileSystemObject")

    '拡張子無しのファイル名を取得
    fileName = FSO.GetBaseName(ActiveDocument.Path & Application.PathSeparator & ActiveDocument.Name)

    '現在のフォルダパス
    Folder_base = ActiveDocument.Path

    'ワークフォルダパス
    Folder_work = ActiveDocument.Path & Application.PathSeparator & fileName

    '開いているファイルのフルパス
    File_base = ActiveDocument.FullName

    'ファイルの拡張子
    file_extension = Replace(ActiveDocument.Name, fileName, "")



    'wordファイルと同名のフォルダを作成
    If Dir(Folder_work, vbDirectory) = "" Then
        MkDir (Folder_work)
    End If


    'これからお世話になるワークファイルのフルパス
    File_work = Folder_work & _
                Application.PathSeparator & _
                fileName & _
                "_work" & _
                file_extension


    '対象のwordファイルをファイル名と同名のフォルダにコピー
     FSO.CopyFile File_base, File_work


    'ワークファイル オープン
    Documents.Open fileName:=File_work
    Documents(fileName & "_work" & file_extension).Activate


    Set xDoc = ActiveDocument


    If InStr(TextBox1.Text, "-") > 0 Then

       '範囲指定の場合
        w_xArr2 = Split(TextBox1.Text, "-")

        ReDim w_xarr(w_xArr2(1) - w_xArr2(0))

        For I = 0 To w_xArr2(1) - w_xArr2(0)
            w_xarr(I) = w_xArr2(0) + I
        Next

    Else

      '個別指定の場合
       w_xarr = Split(TextBox1.Text, ",")

    End If


    xPageCount = UBound(w_xarr)


    Dim w_value As Integer
    Dim w_count As Integer
    Dim w_kensu As Integer
    w_count = 0
    w_kensu = 1


    '対象ファイルの総ページ数
    Page_base = xDoc.Bookmarks("\Page").Range.Information(wdNumberOfPagesInDocument)


    If OpBtn1.Value = True Then

    '分割するファイル数(割り切れない場合は余りを1ファイルにする)
    If Page_base Mod CInt(TextBox1.Text) = 0 Then

        w_kensu = Page_base / CInt(TextBox1.Text)

    Else

        w_kensu = Fix((Page_base / CInt(TextBox1.Text)) + 1)

    End If


    w_value = 1


    ElseIf OpBtn2.Value = True Then


      ReDim xArr(xPageCount)

       xArr = w_xarr


    ElseIf OpBtn3.Value = True Then


      ReDim xArr(Page_base - xPageCount - 2)

      'ループ処理で配列を検索
      For I = 1 To Page_base

         w_value = 0

         For j = 0 To xPageCount
          If StrComp(w_xarr(j), I) = 0 Then

              w_value = 1

            End If

        Next

        If w_value <> 1 Then

          xArr(w_count) = I
          w_count = w_count + 1

        End If


     Next I



    End If


      For K = 1 To w_kensu



      'ページ単位にファイル分割する時の設定
      If OpBtn1.Value = True Then

          '2週目からまたワークファイルを開く
          If K > 1 Then
            FSO.CopyFile File_base, File_work
          End If

          Documents.Open fileName:=File_work
          Documents(fileName & "_work" & file_extension).Activate
          Set xDoc = ActiveDocument


          '削除対象のページを記録しておく配列変数の設定
          If Page_base - w_value + 1 < CInt(TextBox1.Text) Then

            ReDim xArr(w_value - 2) 'ページ分割で最後に余りが出た場合

          Else

            ReDim xArr(Page_base - CInt(TextBox1.Text) - 1) '通常の指定されたページ分割分以外のページを削除

          End If



          'ループ処理で配列を検索
          w_count = 0
          For I = 1 To Page_base




            If (I < w_value) Or (I > w_value + CInt(TextBox1.Text) - 1) Then

              xArr(w_count) = I
              w_count = w_count + 1

            End If


         Next I




         w_value = w_value + CInt(TextBox1.Text)

      End If



        '最終ページから削除していく(1ページ目から削除していくとページ位置が変わってしまうため)
        For I = UBound(xArr) To 0 Step -1
            '★★★★★★★★★★★★★★★★★★★★★★★★★★★★
            Selection.GoTo wdGoToPage, wdGoToAbsolute, xArr(I)
            xDoc.Bookmarks("\Page").Range.Delete
            '★★★★★★★★★★★★★★★★★★★★★★★★★★★★
        Next



          '編集ファイルに最終ページが含まれていない場合は、最終行の行間を編集する。
          '※これをやらないと最終ページに空白のページが出来てしまう。
          If xArr(UBound(xArr)) = Page_base Then

            '最終ページの最終行を選択
            Selection.GoTo wdGoToPage, wdGoToLast
            Selection.GoTo wdGoToLine, wdGoToLast

            '行間を最小にする
            Selection.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
            Selection.ParagraphFormat.LineSpacing = 0.9

          End If


            '最初のページに移動する
            Selection.GoTo wdGoToPage, wdGoToFirst



        '保存
        xDoc.Save

        '対象のwordファイルをファイル名と同名のフォルダにコピー
         FSO.CopyFile xDoc.FullName, _
                                        Folder_work & _
                                        Application.PathSeparator & _
                                        fileName & _
                                        "_" & Format(K, "000") & _
                                        file_extension


        '閉じる
        xDoc.Close

        '削除
        FSO.DeleteFile File_work

     Next


    Set FSO = Nothing

    Application.ScreenUpdating = True


    MsgBox ("処理が完了しました。")
    Unload Word_Split 'フォームを閉じる

End Sub
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 1

check解決した方法

0

外部のソフトウェア(Kutools for Word)を利用すると、任意のページ単位でファイル分割が出来ました。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 87.59%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る