小説家になろうのtxtファイルをWordファイル化

小説家になろうでは、「小説のバックアップをとる」ボタンから小説をテキストファイルでダウンロードすることができる。
私は普段主にGoogle Docsで執筆をしているのだが、誤字報告でいただいた誤字の修正を手元の原稿に反映するのをすっかり失念しており、公開中の内容を最終版としてバックアップするべくこの機能を利用した。

そして、それをWordの体裁に整えようとマクロを組んでみた。どれだけ需要があるかわからないが公開してみる。
尚、ご利用は自己責任で。実行前にきちんとバックアップを取り、保存前のチェックもお忘れなく。

見出しの設定と余計な部分の削除

まずは見出しの設定と余計な要素の削除から。

Sub なろうバックアップを原稿に置換()
    Dim rng As Range
    Dim doc As Document

    Set doc = ThisDocument

    ' 【第n章】の改行を削除
    Set rng = doc.Content
    With rng.Find
        .ClearFormatting
        .Text = "(【第[0-9]{1,3}章】)^13(*)"
        .Replacement.Text = "\1\2"
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With

    ' 章を見出し2に設定
    Set rng = doc.Content
    With rng.Find
        .Text = "【第[0-9]{1,3}章】*"
        .MatchWildcards = True
        Do While .Execute
            rng.Paragraphs.First.Style = "見出し 2"
            rng.Collapse wdCollapseEnd
        Loop
    End With

    ' 【サブタイトル】の改行を削除
    Set rng = doc.Content
    With rng.Find
        .Text = "【サブタイトル】^13"
        .Replacement.Text = "【サブタイトル】"
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With

    ' サブタイトルを見出し3に設定
    Set rng = doc.Content
    With rng.Find
        .Text = "【サブタイトル】*"
        .MatchWildcards = True
        Do While .Execute
            rng.Paragraphs.First.Style = "見出し 3"
            rng.Collapse wdCollapseEnd
        Loop
    End With
        
    ' 【前書き】を見出し4に設定
    Set rng = doc.Content
    With rng.Find
        .ClearFormatting
        .Text = "【前書き】"
        Do While .Execute
            rng.Paragraphs.First.Style = "見出し 4"
            rng.Collapse wdCollapseEnd
        Loop
    End With

    ' 【後書き】を見出し4に設定
    Set rng = doc.Content
    With rng.Find
        .ClearFormatting
        .Text = "【後書き】"
        Do While .Execute
            rng.Paragraphs.First.Style = "見出し 4"
            rng.Collapse wdCollapseEnd
        Loop
    End With

    ' 【本文】を削除
    Set rng = doc.Content
    With rng.Find
        .Text = "【本文】^13"
        .MatchWildcards = True
        .Replacement.Text = ""
        .Execute Replace:=wdReplaceAll
    End With

    ' ---- 第1部分開始 ----を削除
    Set rng = doc.Content
    With rng.Find
        .Text = "-@ 第[0-9]{1,4}部分開始 -@^13"
        .MatchWildcards = True
        .Replacement.Text = ""
        .Execute Replace:=wdReplaceAll
    End With

    ' いいねを削除
    Set rng = doc.Content
    With rng.Find
        .Text = "【いいね】^13*件^13"
        .MatchWildcards = True
        .Replacement.Text = ""
        .Execute Replace:=wdReplaceAll
    End With
End Sub

章は999章、サブタイトルは9999部分までを想定している。超える場合は章なら11行目の「[0-9]{1,3}」、82行目の「[0-9]{1,4}」の最後の数字を適宜修正することで対応できる。

また、第1部分開始前までのユーザー情報と小説情報、最終部分終了後の免責事項は削除していいので、必要であれば手動でどうぞ。

ルビの設定

ルビの設定は下記通り。

Sub ルビの設定()

    Dim oRange As Range
    Dim FoundText As String
    Dim RubyText As String

    ' 検索する文字列のパターン
    Set oRange = ActiveDocument.Range

    With oRange.Find
        .ClearFormatting
        .Text = "**"
        .Replacement.Text = ""
        .MatchWildcards = True
        
        While .Execute(Forward:=True)
            ' マッチしたテキストから必要な部分を抽出
            FoundText = Mid(oRange.Text, 2, InStr(1, oRange.Text, "《") - 2)

            Dim StartPos As Integer, EndPos As Integer
            StartPos = InStr(1, oRange.Text, "《") + 1
            EndPos = InStr(1, oRange.Text, "》") - 1

            If EndPos >= StartPos Then
                RubyText = Mid(oRange.Text, StartPos, EndPos - StartPos + 1)
            Else
                RubyText = ""
            End If

            oRange.Text = FoundText
            If RubyText <> "" Then
                oRange.PhoneticGuide Text:=RubyText, _
                Alignment:=wdPhoneticGuideAlignmentCenter, _
                Raise:=0, FontSize:=8, FontName:="MS Mincho"
            End If
            
            ' 次の検索範囲の開始位置を設定
            oRange.Start = oRange.End
            oRange.End = ActiveDocument.Content.End
        Wend
    End With
End Sub

マクロを活用して、良きなろうライフを！