Wordマクロで、PDFをKindleで読みやすいA6サイズに変換する。2026年版。
◆使用目的・開発理由
・ネットから無料ダウンロードできるPDF形式の小説は、
PC画面で読むのには適したサイズですが、Kindleでは
字が小さすぎて読めないため、用紙サイズをA6に加工します。
・2022年から使用してきたマクロが、2026年3月から
(たぶんOfficeの変更で)動作不良になりました。
（文書の先頭を削除、というマクロが動作しない。）
直そうとすると別の不具合も次々と出てきたため、
大幅な変更をしました。
◆使い方
１．加工の進捗状況を見たい場合は、マクロ実行前に
Altキーを押しながらF11キー。
Crtlキーを押しながらGキー。これでイミディエイトウィンドウが現れます。
イミディエイトウィンドウの位置、サイズを
見やすいよう調整してください。
２．マクロ「PDFを読み込んでDOCXで保存」を実行すると、
どのPDFを開くか、と聞いてきます。
ファイルを選択すると、PDFをWordで開いて、
拡張子.docx で保存します。
３．マクロ「分割とPDF保存」を実行すると、
どのWord文書を開くか、と聞いてきます。
ファイルを選択すると、４万文字ごとに分割して
PDFで保存します。
元のDocxファイルは変更せずに閉じます。
４．マクロ「カクヨムTXTをDOCXにする」を実行すると、
どのtxtファイルを加工するか聞いてきます。ファイルを選択
すると、"［＃改ページ］" などを消して、
別名のtxtで保存します。
（ルビの加工機能はありません。）
Wordマクロファイル 初回だけの準備手順。
■Wordファイルにマクロを入れる方法
スタートボタン｡Win11の場合､アプリの一覧を開く｡
Word をクリック｡
「白紙の文書」をクリック。真っ白な新規文書の画面になる。
Alt+F11キー（キーボードのAltを押しながらF11）。
Visual Basicのウインドウが開く｡
メニューの「挿入」。「標準モジュール」をクリック。
Module1 というウインドウが開く｡
このウインドウの中に､下記のプログラムをコピペする｡
Sub PDFを読み込んでDOCXで保存()
'ボタンで呼び出される。
'Private Sub CommandButton1_Click()
' Call PDFを読み込んでDOCXで保存
'End Sub
Dim dir0 As String, file0 As String, dir1 As String, file1 As String, file2 As String
Dim p_ALL As Long
Debug.Print Now & " : ■ Start ■"
Application.WindowState = wdWindowStateNormal 'ウィンドウを最大化しない
dir0 = ActiveDocument.Path '開くダイアログで最初に表示されるフォルダ
file0 = ActiveDocument.Name 'マクロファイル名
'------------------------------------
If ファイルをダイアログで開く(dir0, "PDFファイル", "*.pdf") = False Then
Exit Sub '開くのをキャンセルしたら先に進まないよう停止
End If
'開いてからの、PDFファイルの場所と名前を取得
dir1 = ActiveDocument.Path
file1 = ActiveDocument.Name
If Right(file1, 3) <> "pdf" And Right(file1, 3) <> "PDF" Then
MsgBox "PDFではありません。"
Exit Sub
End If
Debug.Print " PDFを読み込んでDOCXで保存 開始。"
'保存予定の名前を作成
file2 = Replace(Replace(file1, ".pdf", ""), ".PDF", "") & ".docx"
If Dir(dir1 & "\" & file2) <> "" Then 'ファイルが既存の場合
'MsgBox file2 & "は既にあります。別の名前にします。"
file2 = Replace(file2, ".docx", "_" & Format(Time, "hhmm") & ".docx") '時刻つきに。
End If
'MsgBox "名前をつけて保存します " & vbLf & dir1 & vbLf & file2
ActiveDocument.SaveAs fileName:=dir1 & "\" & file2 '名前を付けて保存
p_ALL = Selection.Information(wdNumberOfPagesInDocument) '総ページ数
'MsgBox "ファイルを閉じます。" & vbLf & "（次の段階に進む前に、閉じる必要があります。） "
Documents(file2).Close '文書を閉じる
Debug.Print Now & "：名前をつけて保存 "
Debug.Print file2 & "、ページ数 " & p_ALL
MsgBox "名前をつけて保存しました。" & vbLf & file2
End Sub
Function ファイルをダイアログで開く(ByVal dir1 As String, ByVal memo As String, ByVal kaku As String) As Boolean
Dim file1 As String, file2 As String
Dim myFD As FileDialog
Dim myFolderPath As String
ファイルをダイアログで開く = False
file1 = ActiveDocument.Name
myFolderPath = dir1 'フォルダパスを設定
'ファイルの選択ダイアログ
Set myFD = Application.FileDialog(msoFileDialogFilePicker)
With myFD
.Title = "ファイルを選択してください"
.AllowMultiSelect = False '複数ファイルの選択をオフ
With .Filters '表示するファイルの種類の設定
.Clear
.Add memo, kaku
End With
.InitialFileName = myFolderPath '最初に表示するフォルダを設定
'ファイルを選択して「OK」ボタンをクリックした場合の処理
If .Show = -1 Then
Documents.Open fileName:=.SelectedItems(1)
End If
.Filters.Clear '表示するファイルの種類の設定を解除
End With
Set myFD = Nothing
If ActiveDocument.Name = file1 Then '開いてない
Exit Function
End If
ファイルをダイアログで開く = True
End Function
Sub 分割とPDF保存()
'ボタンで呼び出される。
'Private Sub CommandButton2_Click()
' Call 分割とPDF保存
'End Sub
Dim dir1 As String, file1 As String, file2 As String
Dim p_ALL As Long, p1 As Long, p2 As Long, p_sep As Long
Dim i As Long
Dim txt1 As String
Dim targetDoc As Document
Dim totalChars As Long
Dim splitSize As Long
Dim startPos As Long, endPos As Long
Dim pdfCount As Integer ' 連番用のカウンター
Dim rSearch As Range
Dim searchLimit As Long
Dim myFontSize As Long: myFontSize = 13 'フォントサイズ
splitSize = 400000 '何文字分を切り出してPDFにするか
Debug.Print Now & " : ■■■■■"
Debug.Print " " & "ファイルを開く。"
If ファイルをダイアログで開く(ActiveDocument.Path, "Word、txtファイル", "*.doc; *.docx; *.txt") = False Then
Exit Sub
End If
Set targetDoc = ActiveDocument
dir1 = targetDoc.Path
file1 = targetDoc.Name
Debug.Print " " & file1
Call ウィンドウを左半分に寄せる(targetDoc)
ActiveWindow.View.Type = wdNormalView ' 下書き表示にして計算負荷を抑える
totalChars = targetDoc.Content.End
startPos = 0
pdfCount = 1 ' 1からスタート
Do While startPos < totalChars - 1
endPos = startPos + splitSize ' いったんの終了目安を決める
If endPos >= totalChars - 1 Then ' 文末チェック
'本の末尾の1文字（セクション情報）を避ける。最終巻は１を引かないとA6横になってしまう。
endPos = totalChars - 1
Debug.Print "本の末尾1文字を避けて範囲確定。"
Else
' 句読点「。」で区切るロジック
searchLimit = endPos + 1000 '1000文字先まで調べる
If searchLimit > totalChars - 1 Then searchLimit = totalChars - 1
Set rSearch = targetDoc.Range(endPos, searchLimit)
With rSearch.Find
.Text = "。"
.Forward = True
.Wrap = wdFindStop
If .Execute Then endPos = rSearch.End ' 「。」の直後を終了位置にする
End With
End If
Debug.Print " 取り出し範囲Pos " & startPos & "～" & endPos & "文字め。"
Call 抽出してA6PDF保存_Pos版(targetDoc, startPos, endPos, myFontSize, pdfCount)
startPos = endPos
pdfCount = pdfCount + 1 ' 次のファイルのために1増やす
If startPos >= totalChars Then Exit Do
Loop
targetDoc.Close SaveChanges:=False ' 元の文書を閉じる
MsgBox "全 " & (pdfCount - 1) & " ファイルの作成が完了しました。"
End Sub
Sub 抽出してA6PDF保存_Pos版(ByRef srcDoc As Document, pStart As Long, pEnd As Long, fSize As Long, fileIdx As Integer)
Dim newDoc As Document
Dim r As Range
Dim savePath As String, baseName As String, PfileName As String
' 元のファイル名から拡張子を除いた部分を取得
baseName = Left(srcDoc.Name, InStrRev(srcDoc.Name, ".") - 1)
baseName = Left(baseName, 15)
PfileName = baseName & "_" & Format(fileIdx, "00") & ".pdf" 'PDFファイル名
savePath = srcDoc.Path & "\" & PfileName ' 保存パスの作成
Set r = srcDoc.Range(pStart, pEnd) ' 範囲取得
r.Copy ' コピー
Set newDoc = Documents.Add(Visible:=True) '新規文書作成
newDoc.Activate '最前面に
Call ウィンドウを左半分に寄せる(newDoc)
'縦書き＆用紙を縦、というのは困難なため、横書き
newDoc.Range.Orientation = wdTextOrientationHorizontal '横書き
'用紙サイズなどを設定。大量の文字を貼ってからだとフリーズするので、カラ状態で実行。
With newDoc.PageSetup
.HeaderDistance = 0
.FooterDistance = 0
.TopMargin = MillimetersToPoints(1) '余白
.BottomMargin = MillimetersToPoints(9)
.LeftMargin = MillimetersToPoints(2)
.RightMargin = MillimetersToPoints(5)
.PageWidth = MillimetersToPoints(100) '用紙の幅
.PageHeight = MillimetersToPoints(141)
.Orientation = wdOrientPortrait '用紙「縦向き」
End With
Debug.Print " ページ設定した。"
newDoc.Content.Paste ' 文字を大量に貼り付け
Debug.Print " カラのWord文書に文字を貼り付けした。"
' --- 貼り付け直後に実行：孤立した数字（1～4桁）を消去する ---
With newDoc.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "^13[0-9]{1,4}^13"
.Replacement.Text = "^p"
.MatchWildcards = True ' ← ここはONにする
.Execute Replace:=wdReplaceAll
End With
Debug.Print " 元のページ番号を消した。"
' 文書内の「セクション区切り」をすべて「改ページ」に置換
' これにより、コピー元の「縦書き・横向き」設定が復活するのを防ぎます
With newDoc.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "^b" ' セクション区切りの記号
.Replacement.Text = "^m" ' 通常の改ページの記号
.Execute Replace:=wdReplaceAll
End With
Debug.Print " セクション区切りを削除した。"
'全体のフォントサイズと「行間」の調整
With newDoc.Content
.Font.Size = fSize
With .ParagraphFormat ' 行間が広すぎるのを防ぐ設定
.LineSpacingRule = wdLineSpaceExactly ' 行間を固定値に指定
.LineSpacing = fSize * 1.4 'フォントサイズの＊倍に固定。1.2だとルビと文字が接触する。
.SpaceBefore = 0 ' 段落前の余白ゼロ
.SpaceAfter = 0 ' 段落後の余白ゼロ
End With
End With
Debug.Print " フォントサイズ" & fSize & "にした。"
Dim sec As Section
For Each sec In newDoc.Sections
sec.Footers(wdHeaderFooterPrimary).Range.Font.Size = 8 ' フッターのフォントサイズ固定
sec.Footers(wdHeaderFooterPrimary).Range.ParagraphFormat.Alignment = wdAlignParagraphRight ' 右寄せ
Next sec
Debug.Print " フッターのフォントを小さくした。PDF保存開始。"
' PDF出力
newDoc.ExportAsFixedFormat OutputFileName:=savePath, ExportFormat:=wdExportFormatPDF
newDoc.Close SaveChanges:=False
Debug.Print Now & " " & "PDF保存 "
Debug.Print "" & PfileName
End Sub
Sub ウィンドウを左半分に寄せる(targetDoc As Document)
Dim halfWidth As Double
targetDoc.ActiveWindow.WindowState = wdWindowStateNormal 'まず「標準サイズ」に
halfWidth = Application.UsableWidth / 2 '使用可能な最大幅の半分を計算
With targetDoc.ActiveWindow ' 位置とサイズを指定
.Top = 0 ' 画面の一番上
.Left = 0 ' 画面の一番左
.Width = halfWidth ' 幅は全体の半分
.Height = Application.UsableHeight ' 高さは最大
End With
End Sub
Sub カクヨムTXT置換() '（ChatGPTにて作成）
'ボタンで呼び出される。
'Private Sub CommandButton3_Click()
' Call カクヨムTXT置換
'End Sub
Dim dlgOpen As FileDialog
Dim originalFileName As String
Dim newFileName As String
Dim filePath As String
Dim targetDoc As Document
Debug.Print Now & " : ■■ カクヨム Start ■■"
' ファイル選択ダイアログを開く
Set dlgOpen = Application.FileDialog(msoFileDialogFilePicker)
With dlgOpen
.Title = "開くテキストファイルを選択"
.Filters.Clear
.Filters.Add "Text Files", "*.txt"
.AllowMultiSelect = False
.InitialFileName = ThisDocument.Path & "\" ' ダイアログの初期フォルダを設定
' ユーザーがファイルを選択した場合
If .Show = -1 Then
originalFileName = .SelectedItems(1) ' 選択したファイルのフルパス
Documents.Open originalFileName ' ファイルを開く
Set targetDoc = ActiveDocument
dir1 = targetDoc.Path
file1 = targetDoc.Name
Debug.Print " " & file1
Call ウィンドウを左半分に寄せる(targetDoc)
' 置換処理
Debug.Print " 文字列置換する"
Call 文字列置換("［＃改ページ］", "------------------" & vbCrLf)
Call 文字列置換("［＃中見出し］", "■■ ")
Call 文字列置換("［＃中見出し終わり］", " ■■ " & vbCrLf)
Call 文字列置換("［＃大見出し］", "■■■ ")
Call 文字列置換("［＃大見出し終わり］", " ■■■ " & vbCrLf)
Call 文字列置換("［＃丸傍点］", "")
Call 文字列置換("［＃丸傍点終わり］", "")
Call 文字列置換("※［＃始め二重山括弧、1-1-52］", "〈〈")
Call 文字列置換("※［＃終わり二重山括弧、1-1-53］", "〉〉")
Call 文字列置換("※［＃縦線、1-1-35］", " －－ ")
'
' 新しいファイル名を作成。
newFileName = Replace(originalFileName, ".txt", "_.txt")
'
' 新しいファイル名で保存
ActiveDocument.SaveAs2 fileName:=newFileName, FileFormat:=wdFormatUnicodeText 'UTF-8 保存
ActiveDocument.Close '閉じる
Debug.Print Now & " 保存した"
Debug.Print Dir(newFileName)
MsgBox "アンダーバー付きの別名で保存しました " & vbLf & Dir(newFileName), vbInformation
Else
MsgBox "ファイルが選択されませんでした。", vbExclamation
End If
End With
'「［＃改ページ］」などの文字を消すだけで、ルビの加工機能はない。
'カクヨムのtxtファイルには、ルビにするための記号があり、
'理論上は小さいルビ文字に加工できるものの、実際には高負荷でフリーズ
'してしまうため、断念。
'2026年4月、変換個数をカウントして試したところ、600箇所を処理した
'ところで「応答なし」になりフリーズした。
End Sub
Sub 文字列置換(oldtxt As String, newtxt As String)
Dim doc As Document
Set doc = ActiveDocument
With doc.Content.Find
.Text = oldtxt
.Replacement.Text = newtxt
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
End Sub
左側、「Module1」の下に「ThisDocument」があるので､
ダブルクリック｡
ThisDocument のウインドウが開く｡
この中に､下記のプログラムを貼る。
Private Sub CommandButton1_Click()
Call PDFを読み込んでDOCXで保存
End Sub
Private Sub CommandButton2_Click()
Call 分割とPDF保存
End Sub
Private Sub CommandButton3_Click()
Call カクヨムTXT置換
End Sub
Private Sub Document_Open()
Application.Move Left:=2, Top:=10 ウインドウを左寄せ
Application.Resize Width:=734, Height:=333
End Sub
＜文書上にボタンを置く方法＞
Word文書のウインドウ（Visual Basicではないほう）。
上のメニューの「校閲」「表示」の右に「開発」がない場合は、
メニュー文字やリボンの上で右クリックして
「リボンのユーザー設定」、
「開発」にチェックを入れ、OKボタン。
「開発」のリボンの中、「コントロール」欄。
小さいボタンが並んでいる中で､黒いカバンのようなボタン
（以前のバージョンのツール）をクリック。
小さいボタン群が現れた中で､白い長方形 (コマンドボタン)
をクリック｡
文書上に､CommandButton1 が現れる｡
メニュー（開発タブの中）の「デザインモード」をクリックして
「デザインモード」がグレーで押された状態にする。
その直下の「プロパティ」をクリック。
プロパティウインドウが現れる｡
プロパティウインドウで､一番上の選択肢からCommandButton1を選ぶ｡
設定項目が10個以上ある中で「Caption」が、現在「CommandButton1」になっているのを、
「PDFを読み込んでDOCXで保存」など、自分でわかりやすい言葉に変える｡
あと2つ､同様にボタンを作る｡
（コマンドボタン。CommandButton2が現れる。
プロパティで、Captionを「分割とPDF保存」にする。）
（コマンドボタン。CommandButton3が現れる。
プロパティで、Captionを「カクヨムTXT置換」にする。）
ボタンが配置できたら、「デザインモード」をクリックして、
「デザインモード」が押されていない状態に戻す。
＜名前をつけて保存＞
メニューの「ファイル」、「名前を付けて保存」。
「このPC」。保存したいフォルダを選ぶ。
（加工対象のPDFを保存するのと同じ場所がよい。）
名前を付ける画面で、初期状態「文書1.docx」の文字を
全部消して、例えば「PDF分割マクロ」と入力する。
その直下、ファイルの種類は、必ず、
「Wordマクロ有効文書」を選ぶ。
「保存」をクリック。
■カスタマイズするには。
1．マクロ「Sub 分割とPDF保存()」の中の
「Dim myFontSize As Long: myFontSize = 13 フォントサイズ
splitSize = 400000 何文字分を切り出してPDFにするか」
を､変更したい場合は変更します｡
2．マクロ「抽出してA6PDF保存_Pos版」は、
用紙をA6サイズぐらい設定するようになっているので、
変更したい場合は数字を調整します。