All season with my Dear

All season with my Dear

PR

×

カレンダー

プロフィール

Tsukatsuka

Tsukatsuka

キーワードサーチ

▼キーワード検索

2020年04月21日
XML
カテゴリ: マクロ

よく公開してあるマクロを参考にさせていただくので,
私も公開しようかなと思いました。

Wordで,別ファイルに置換データ(置換ファイル)を作っておいて,置換したい文書ファイルを一括置換するマクロです。
置換ファイルは1行1データ,もちろん複数行OK。
書式:<行頭>置換文字列<tab>検索文字列<TAB>nasi<以降の文字列は無視>


改造してもっといいのができたら,私にもちょうだい^^

(以下マクロ本文)
Sub 一括置換()
'
' 一括置換 Macro
'置換ファイル=*.txt
'<行頭>置換文字列<tab>検索文字列<TAB>nasi<以降の文字列は無視>
'置換文字列が空文字なのは置換しない
'正規表現の書き方がWZEditorとは違うので注意あまり複雑な正規表現は無理
'<tab>のない文字列は無視
'nasiの場合は確認しない
'エラーが出るとそこで終了する
' 作成日 2015/02/13 作成者 つかさ猫
On Error GoTo 一括置換_Error
'relファイル
Dim rel As Word.Document
'文書ファイル=アクティブドキュメント
'Dim actdoc As Range
'ファイル名を取得する
    i = InStrRev(ActiveDocument.Path, "\")
    tkwpath = Left(ActiveDocument.Path, i)
With Application.FileDialog(msoFileDialogFilePicker)
    .ButtonName = "選択"
    .InitialFileName = tkwpath
    With .Filters
        .Clear
        .Add "置換ファイル", "*.txt;*.doc;*.docx", 1
        .Add "すべてのファイル", "*.*", 2
    End With
    If .Show = -1 Then
        'relを読込専用で読込
        Set rel = Documents.Open(.SelectedItems(1), ReadOnly:=True, Visible:=False)
    Else    'キャンセル
        GoTo 一括置換_End
    End If
End With
'relファイルの中身すべてを配列で
Dim relline() As String
'rellineの1行の検索・置換文字列を配列で
Dim relwd() As String
'c=relの全行数
Dim c As Integer
    c = rel.BuiltInDocumentProperties(wdPropertyLines)
'スキップ行
Dim relskip
    relskip = "#"
ReDim relline(c)
For i = 1 To c
    'relファイルの中身を全部取得
'        relline(i) = Replace(rel.Paragraphs(i).Range, vbCr, "")
        relline(i) = rel.Paragraphs(i).Range
    'i行目をrelwdに配列で格納,区切り文字\t
    If (relline(i) <> vbNewLine) Then  '改行だけの行は飛ばす
        relwd = Split(relline(i), Chr(9), 3)
        '検索文字列と置換文字列が""じゃない
        '#で始まらない
        'relwdのインデックスが2以上
        Dim cond(4) As Boolean '検索を実行するcondition
        cond(0) = (relwd(0) <> "")
        cond(2) = (Left(relwd(0), 1) <> relskip)
        If (UBound(relwd) > 0) Then
            cond(1) = (relwd(0) <> "")
            cond(3) = True
        Else
            cond(1) = False
            cond(3) = False
        End If
        If (UBound(relwd) > 2) Then
            If (relwd(2) = "nasi") Then
                cond(4) = True
            Else
                cond(4) = False
            End If
        End If
        If (cond(0) And cond(1) And cond(2) And cond(3)) Then
   '             MsgBox relwd(0) & " " & relwd(1)
            relwd(1) = Replace(relwd(1), vbLf, "")
            relwd(1) = Replace(relwd(1), vbCr, "")
            StatusBar = "検索文字列:" & relwd(1) & "          置換文字列:" & relwd(0)
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
            .Text = relwd(1)    '検索文字列
            .Forward = True '検索方向=文末方向
            .Wrap = wdFindContinue  '文書の末尾まで達したら先頭から検索
            .Format = False '書式検索
            .MatchCase = False     '大文字と小文字を区別しない
            .MatchWholeWord = False '単語検索しない
            .MatchByte = False  '全半角の区別しない
            .MatchAllWordForms = False  '検索語の活用形も検索しない(英語だけ?)
            .MatchSoundsLike = False    '似た語の検索しない
            .MatchFuzzy = False  'あいまい検索しない
            .MatchWildcards = True '正規表現で検索する
            .Replacement.Text = relwd(0)    '置換文字列
            .Replacement.Font.Bold = True '置換した文字を太字に
            ret = .Execute(Replace:=2) '検索実行,確認しない
            End With
        End If
    End If
     ActiveDocument.AcceptAllRevisionsShown
Next
GoTo 一括置換_End
一括置換_Error:
        MsgBox "エラーです:" & Chr(13) & Chr(10) _
         & i & "行目:" & Chr(13) & Chr(10) _
         & "検索文字列(" & relwd(0) & ")" _
         & "置換文字列(" & relwd(1) & ")"
Resume Next
一括置換_End:
 rel.Close SaveChanges:=wdDoNotSaveChanges
End Sub





お気に入りの記事を「いいね!」で応援しよう

最終更新日  2020年04月21日 18時30分05秒
コメント(0) | コメントを書く


【毎日開催】
15記事にいいね!で1ポイント
10秒滞在
いいね! -- / --
おめでとうございます!
ミッションを達成しました。
※「ポイントを獲得する」ボタンを押すと広告が表示されます。
x
X

コメント新着

コメントに書き込みはありません。

© Rakuten Group, Inc.
X

Design a Mobile Website
スマートフォン版を閲覧 | PC版を閲覧
Share by: