読者です 読者をやめる 読者になる 読者になる

Fight the Future

何かを始めたら、半分成功したのと同じ

Wordで複数の単語をまとめて置換するユーザーフォームを使ったマクロ

やたらタイトルが長くなったけど、
要は置換する対象の単語がたくさんあって、1つずづ置換するのは面倒だからまとめて一気に置換させる。
さらにユーザーフォームを使って使いやすくして、置換する単語もCSVでインポートできる。
アドインの形式で使う。


こんなボタンがツールバーにできて。
f:id:jyukutyo:20081002105149j:image

こんなフォームが出てくる。
f:id:jyukutyo:20081002105150j:image

全置換実行ボタンを押すと、変換する。しかもWordの変更履歴にすべて記録する。
同時に、入力した項目をファイルに保存する。
f:id:jyukutyo:20081002105151j:image

ソースコード

ファイル添付できないので、ソースをのせます。


まず、ユーザーフォームを作ってください。

コントロール オブジェクト名 説明
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でツール→テンプレートとアドインから作成したファイルを追加します。
f:id:jyukutyo:20081002105148j:image
すると、ツールバーに全置換ボタンが出てきたはずです!
ボタンを押すか、「Alt + R」のショートカットキーで起動します。


全置換実行ボタンを押すと文書と同じディレクトリに「全置換マクロ項目.txt」にCSV形式で置換項
目を保存します。
単なる2列のCSV形式なので、ほかのアプリからでも出力できると思います。