複数のWord文書に対して文字列リストを元に連続して置換するマクロ

Pocket

以前、Wordに関する次の二つのマクロを紹介しました。
Wordで文字列リストを元に連続して置換するマクロ
複数のWord文書に対して文字列置換
今般、「これらを組み合わせたい」という要望をいただきましたので、試してみました。

2020年7月18日追記
「下階層のファイルにも対応させたい」という要望をいただきましたので、試してみました。

目次

準備
リスト
コード
下階層対応版

準備

適当なフォルダに文字列置換したいWordファイルを保存します。これを「対象フォルダ」と呼びます。
確認せずに一気に置換して上書き保存しますので、これらのファイルは必ずバックアップを取っておいてください。
利用に関しては自己責任でお願いします。

リスト

マクロ実行用のWordファイルを準備します。「対象フォルダ」とは別のフォルダに保存します。
本文に次のようなリストを書いておきます。
置換前と置換後の文字列を並べ、セミコロン(;)で区切ります。

エディター;エディタ
プリンター;プリンタ
サーバー;サーバ

コード

次のコードを使います。使い方が分からない場合は「マクロを書く方法」を参照してください。
マクロを実行するとフォルダを選ぶダイアログが出ます。「対象フォルダ」を選択してください。
選択するとフォルダ内のファイルが順に開き、リストに従って次々に置換が実行され、上書き保存されます。

Sub 複数文書連続処理_リストを元に置換()
  Dim mae(100)
  Dim ato(100)
 
  '置換用配列
  Set paras = ActiveDocument.Paragraphs
  x = 0
  For i = 1 To paras.Count
    thisline = paras(i).Range.Text
    parts = Split(thisline, ";")
    If UBound(parts) > 0 Then
      mae(x) = parts(0)
      ato(x) = Replace(parts(1), Chr(13), "")
      x = x + 1
    End If
  Next i
 
  'フォルダの選択
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "フォルダを選択"
    .AllowMultiSelect = False
    If .Show = -1 Then
      mypath = .SelectedItems(1) & "\"
    Else
      MsgBox "終了します。"
      Exit Sub
    End If
  End With
 
  'Word文書に対する処理
  myfile = Dir(mypath & "*.doc*")
  Do While myfile <> ""
    Documents.Open FileName:=mypath & myfile
    For i = 0 To x - 1
      Call 文書全体を置換(mae(i), ato(i))
    Next i
    ActiveWindow.Close SaveChanges:=wdSaveChanges
    myfile = Dir
  Loop
End Sub
Function 文書全体を置換(mae, ato)
  Set myrange = ActiveDocument.Range(Start:=0, End:=0)
  With myrange.Find
    .ClearFormatting
    .Text = mae
    With .Replacement
      .ClearFormatting
      .Text = ato
    End With
    .Execute Replace:=wdReplaceAll
  End With
End Function

下階層対応版

下の階層を含めたファイル一覧を作成するマクロ」を参考にして、指定したフォルダの配下のフォルダに対応したバージョンを作りました。
宣言以降、全てのコードを下のとおり、まとめました。全てをコピー&ペーストするだけで使えます。

Dim all_files(9999, 1) As String
Dim last_index

Sub 複数文書連続処理_リストを元に置換()
  Dim mae(100)
  Dim ato(100)
 
  '置換用配列
  Set paras = ActiveDocument.Paragraphs
  x = 0
  For i = 1 To paras.Count
    thisline = paras(i).Range.Text
    parts = Split(thisline, ";")
    If UBound(parts) > 0 Then
      mae(x) = parts(0)
      ato(x) = Replace(parts(1), Chr(13), "")
      x = x + 1
    End If
  Next i
 
  'フォルダの選択
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "フォルダを選択"
    .AllowMultiSelect = False
    If .Show = -1 Then
      mypath = .SelectedItems(1) & "\"
    Else
      MsgBox "終了します。"
      Exit Sub
    End If
  End With
 
  '全てのファイル名を取得(下階層を含む)
  Call get_files(mypath)
 
  'Word文書に対する処理
  j = 0
  Do
    Documents.Open FileName:=all_files(j, 1) & all_files(j, 0)
    For i = 0 To x - 1
      Call 文書全体を置換(mae(i), ato(i))
    Next i
    ActiveWindow.Close SaveChanges:=wdSaveChanges
    j = j + 1
  Loop Until all_files(j, 0) = ""
End Sub
Function 文書全体を置換(mae, ato)
  Set myrange = ActiveDocument.Range(Start:=0, End:=0)
  With myrange.Find
    .ClearFormatting
    .Text = mae
    With .Replacement
      .ClearFormatting
      .Text = ato
    End With
    .Execute Replace:=wdReplaceAll
  End With
End Function
Function get_files(my_path)
  'Word用
  '指定したフォルダにある全てのファイル名(パス付)を取得する。
  Dim this_file(999) As String
  Dim this_path As String
  Dim i As Long
  Dim j As Long
  this_file(0) = Dir(my_path, vbDirectory)
  i = 0
  Do
    i = i + 1
    this_file(i) = Dir
  Loop Until this_file(i) = ""
  For j = 0 To i - 1
    If this_file(j) <> "." And this_file(j) <> ".." Then
      If InStr(this_file(j), ".doc") = 0 Then
        Call get_files(my_path & this_file(j) & "\")
      Else
        all_files(last_index, 0) = this_file(j)
        all_files(last_index, 1) = my_path
        last_index = last_index + 1
      End If
    End If
  Next j
End Function

[ 2020年5月22日 | カテゴリー: Word | タグ: , ]

« | »

コメント

  1. 新後閑真 より:

    ありがとうございます!
    さっそく試してみたのですが、なぜか上手くいきませんでした泣
    私の操作が問題なのかもしれないのですが、「Wordで文字列リストを元に連続して置換するマクロ、複数のWord文書に対して文字列置換」は上手く作動したのですが、、、

  2. stabucky より:

    >新後閑真さん
    チェックしたところ、コードに誤りがありました。失礼しました。
    (「mypath = .SelectedItems(1) & “\”」の部分が「mypath = .SelectedItems(1) & “”」となっていました。ブログにペーストするときに必要な部分が消えてしまいました。)
    お手数ですが、再度、試していただけると助かります。
    よろしくお願いします。

  3. 新後閑真 より:

    >stabuckyさま
    修正いただき、ありがとうございます!
    動作確認したところ、無事に置換できました!!

  4. stabucky より:

    ありがとうございます。お役に立てたのであれば幸いです。

  5. kremlin より:

    いつも画期的なマクロを公開していただき使わせて頂いております。一つ相談なのですが、親フォルダを指定したらその親フォルダ配下のすべてのフォルダに保存されているwordファイルを置換するように出来ますでしょうか。無理を言いまして、申し訳ありませんが、御一考のほどよろしくお願い致します。

  6. stabucky より:

    kremlinさん
    了解しました。
    お約束はできませんが検討してみます。

  7. stabucky より:

    kremlinさん
    下階層対応版を書いてみました。
    試していただけると助かります。
    バックアップを忘れずにお願いします。

  8. kremlin より:

    stabucky様
    早速ありがとうございます。
    来週、試させて頂きます。
    職場環境がソフトのインストールができない環境なので
    stabucky様のマクロは非常に助かります。
    また、使用後、返信させて頂きます。
    ありがとうございます。

  9. stabucky より:

    kremlinさん
    よろしくお願いします。

  10. kremlin より:

    stabucky様
    お世話になっております。
    ただいま、作成していただいたマクロを
    実行した結果、「実行時エラー52ファイル名または番号が不正です。」とメッセージが表示されて実行できませんでした。
    デバックで見ると、this_file(0)=dir(my_path,vbdirectory)の部分で
    停止しておりました。
    私の環境の問題でしょうか。お手数おかけ致しますが、時間があるときに見ていただけると幸い

  11. stabucky より:

    kremlinさん
    私の環境では再現しませんでした。
    考えられる点としては。
    VBAのコードで
    mypath = .SelectedItems(1) & “\”
    の最後の部分が”¥”となっていますでしょうか。
    確認ください。

  12. kremlin より:

    stabucky様
    おはようございます。
    ご連絡いただきました箇所を確認したところ、¥になっておりました。素人考えですが、当方の環境がネットワークドライブであったり階層深かったりフォルダ名が悪さしているのかなと考えています。今回は大変お手数おかけいたしました。これ以上お手数おかけ致すわけには行きませんので、一つずつ置換していきます。ありがとうございました。

コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です

送信してください。


タグ

カテゴリー

最近の投稿

最近のコメント

固定ページ

アーカイブ

stabucky

写真

メタ情報