やたらタイトルが長くなったけど、
要は置換する対象の単語がたくさんあって、1つずづ置換するのは面倒だからまとめて一気に置換させる。
さらにユーザーフォームを使って使いやすくして、置換する単語もCSVでインポートできる。
アドインの形式で使う。
全置換実行ボタンを押すと、変換する。しかもWordの変更履歴にすべて記録する。
同時に、入力した項目をファイルに保存する。
ソースコード
ファイル添付できないので、ソースをのせます。
まず、ユーザーフォームを作ってください。
コントロール | オブジェクト名 | 説明 |
---|---|---|
UserForm | UserForm1 | |
TextBox | Before | 置換前の単語を入力する |
TextBox | After | 置換後の単語を入力する |
ListBox | WordList | 置換項目の一覧を表示する |
CommandButton | Add | 項目をリストに追加する |
CommandButton | Delete | 項目をリストから削除する |
CommandButton | Import | 項目を記述したCSVファイルをインポートする |
CommandButton | Replace | 置換を実行する |
ユーザーフォームに以下のコードを記述してください。
Option Explicit Private Sub Add_Click() If Before.Value = "" Then MsgBox "置換前の文字列を入力してください" Else WordList.AddItem (Before.Value) WordList.List(WordList.ListCount - 1, 1) = After.Value Before.Value = "" After.Value = "" End If Before.SetFocus End Sub Private Sub Delete_Click() If WordList.ListIndex = -1 Then MsgBox "削除する項目を選択してください" Else WordList.RemoveItem (WordList.ListIndex) End If End Sub Private Sub Import_Click() Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False If Application.FileDialog(msoFileDialogOpen).Show = -1 Then Dim FileNumber As Integer FileNumber = FreeFile Open Application.FileDialog(msoFileDialogOpen).SelectedItems(1) For Input As #FileNumber Dim LineNumber As Long LineNumber = 1 Dim LineContent As String Do Until EOF(FileNumber) Line Input #FileNumber, LineContent LineNumber = LineNumber + 1 Dim Items() As String Items = Split(LineContent, ",") WordList.AddItem (Items(0)) WordList.List(WordList.ListCount - 1, 1) = Items(1) Loop Close #FileNumber End If End Sub Private Sub Replace_Click() If IsEmpty(WordList) Then MsgBox "置換する項目が1つもありません" Exit Sub ElseIf WordList.ListCount < 1 Then MsgBox "置換する項目が1つもありません" Exit Sub End If With ActiveDocument .TrackRevisions = True .ShowRevisions = True CommandBars("Reviewing").Visible = True End With Dim Items As Variant Items = WordList.List Dim i As Integer For i = LBound(Items) To UBound(Items) Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = Items(i, 0) .Replacement.Text = Items(i, 1) .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = False .MatchFuzzy = False End With Selection.Find.Execute Replace:=wdReplaceAll Next Dim File As Object Set File = CreateObject("Scripting.FileSystemObject") Dim Stream As Object Set Stream = File.CreateTextFile(ThisDocument.Path & "\全置換マクロ項目.txt", True) For i = LBound(Items) To UBound(Items) Stream.WriteLine Items(i, 0) & "," & Items(i, 1) Next Stream.Close: Set File = Nothing: Set Stream = Nothing Unload Me End Sub Private Sub UserForm_Initialize() WordList.ColumnCount = 2 Before.IMEMode = fmIMEModeOn After.IMEMode = fmIMEModeOn End Sub
ドキュメント(ThisDocument)に次のコードを記述してください。
Sub UserForm_Show() UserForm1.Show End Sub 'アドインをインストールしたときに自動実行させる Sub AutoExec() On Error Resume Next Dim Bar As CommandBar Set Bar = Application.CommandBars("マクロ") If Bar Is Nothing Then Set Bar = Application.CommandBars.Add("マクロ") Bar.Position = msoBarTop Dim Menu As CommandBarButton Set Menu = Bar.Controls.Add(Type:=msoControlButton) Menu.Caption = "全置換(&R)" Menu.OnAction = "UserForm_Show" Menu.Width = 60 Menu.BeginGroup = True Menu.Style = msoButtonCaption End If Bar.Visible = True End Sub
このファイルを文書テンプレート(.dot)形式で保存します。
アドインとして利用できるので、Wordでツール→テンプレートとアドインから作成したファイルを追加します。
すると、ツールバーに全置換ボタンが出てきたはずです!
ボタンを押すか、「Alt + R」のショートカットキーで起動します。
全置換実行ボタンを押すと文書と同じディレクトリに「全置換マクロ項目.txt」にCSV形式で置換項
目を保存します。
単なる2列のCSV形式なので、ほかのアプリからでも出力できると思います。