More than 3 years have passed since last update.

【Word VBA】読み込んだCSVの任意列から任意列へ語句を一括置換（ユーザーフォーム）

Posted at 2020-10-17

やりたいこと

翻訳やら変更箇所やらをCSVファイルに書いておいて、それを使ってWordファイル中の語句を変換することがある。
しかし、例えば同じ変換用ファイルを使って日→英の単語変換と英→中の単語変換ができたらいいなと思うことがある。
探したら（探し方が悪いのかもしれないが）1列目と2列目の間の変換しか見つからなかったので、複数列の中から任意の2列を選択できるよう、ユーザーフォームで作ってみた。
ちなみに自列同士を選択して蛍光ペンを引くようにすれば語句チェッカーとしても使える。

やってみたこと

CSVを読み込んでみたらUTF-8で文字化けしていたので、（Line InputはShift-JISしかダメみたい）文字化けしてたらUTF-8で再読み込みできるようにした。
- Microsoft ActiveX Data Objects 2.8 Library　を予め参照設定する。
置換リストの確認：フォーム側でプレビューを用意しなくても元ファイルを開けばいいじゃないか、と考えたので「編集」ボタンを設置。
CSVの何行目をヘッダとして扱うかは場合により違うらしいので、フォームから設定できるようにした。

開発環境

Windows10
Microsoft Visual Basic for Applications 7.1
Microsoft Word (おそらく2013)

フォーム構成と各パーツの名前

Bt: ボタン
Tb:テキストボックス
Cb:コンボボックス
Ck:チェックボックス
Sb:スピンボタン

コード

FrmReadCSV.frm

Option Explicit

'共通変数の宣言
Private i As Long
Private arr_csv() As String


Private Sub BtOpen_Click()
    'CSVを開く（ダイアログ部分）
    Dim FilePath As String
    
    With Application.FileDialog(msoFileDialogFilePicker)
        With .Filters
          .Clear
          .Add "csv", "*.csv"
        End With
        .AllowMultiSelect = False
        
        If .Show = -1 Then
            FilePath = .SelectedItems(1)
            .Filters.Clear
        Else
            .Filters.Clear
            Exit Sub
        End If
    
    End With
    TbFile.Value = FilePath
    
    Call BtReload_Click
    
End Sub

Private Sub BtReload_Click()
    '（再）読み込み
    
    If TbFile.Value = "" Then Exit Sub
    arr_csv() = ReadCSV(TbFile, CkUTF8.Value)
    SbHeaderLine.Max = UBound(arr_csv) - LBound(arr_csv) '+1
    
    Call ApplyToCbBefore_CbAfter
    
End Sub

Private Function ApplyToCbBefore_CbAfter()
    'arr_csvのヘッダ行をコンボボックスに反映させる処理
    
    Dim FirstLine As Variant
    Dim intHLine As Integer
    
    '列リストのクリア
    CbBefore.Clear
    CbAfter.Clear
    
    'ヘッダ行の内容を読み込み（なかったら１行目）
    intHLine = 1
    If CInt(TbHeaderLine.Value) > intHLine Then intHLine = TbHeaderLine.Value
    
    FirstLine = Split(arr_csv(LBound(arr_csv) + TbHeaderLine.Value), ",")
    For i = LBound(FirstLine) To UBound(FirstLine)
        CbBefore.AddItem FirstLine(i)
        CbAfter.AddItem FirstLine(i)
    Next
    '読み込んだ後、インデックスを動かしておく
    CbBefore.ListIndex = 0
    CbAfter.ListIndex = 0
End Function


Private Sub BtEdit_Click()
    '編集用に開くボタン（Shellで開くだけ）
    If TbFile.Value = "" Then Exit Sub
    i = Shell(Environ("WINDIR") & Application.PathSeparator & "explorer.exe " & TbFile.Value, vbNormalFocus)
End Sub


Private Function ReadCSV(FilePath, Optional isUTF8 As Boolean) As String()
    'CSVの読み込み 1行（レコード）ごとの配列で返す
    
    Dim intFNum As Integer  ' ファイル番号
    Dim Rcd As Variant  ' 1行分（1レコード）
    Dim arrRcd() As String '一時格納する動的配列
    Dim intCnt As Integer '配列の上限値カウント用
        
    'CSV読み込み
    If FilePath = "" Then
        MsgBox ("ファイルパスがありません")
        Exit Function
    End If
    
    ReDim arrRcd(0)
    If isUTF8 Then
        Dim adoSt As Object
        Set adoSt = CreateObject("ADODB.Stream")
        
        With adoSt
            .Charset = "UTF-8"
            .Open
            .LoadFromFile (FilePath)
        
            Do Until .EOS
                Rcd = .Readtext(adReadLine)
                intCnt = UBound(arrRcd)
                ReDim Preserve arrRcd(intCnt + 1)
                arrRcd(intCnt + 1) = Rcd
                Debug.Print Rcd
            Loop
        
            .Close
        End With
        Set adoSt = Nothing
    Else
        intFNum = FreeFile
        Open FilePath For Input As intFNum

        Do Until EOF(intFNum)
            Line Input #intFNum, Rcd
            intCnt = UBound(arrRcd)
            ReDim Preserve arrRcd(intCnt + 1)
            arrRcd(intCnt + 1) = Rcd
            Debug.Print Rcd
        Loop
        Close intFNum
    End If

    ReadCSV = arrRcd()
    
End Function


Private Sub SbHeaderLine_Change()
    'スピンボタンの挙動
    TbHeaderLine.Value = SbHeaderLine.Value
End Sub

Private Sub TbHeaderLine_Change()
    'ヘッダー列の設定が変わったらリロード(最大値と最小値を調整)
    If TbHeaderLine.Value < 0 Then TbHeaderLine.Value = 0
    On Error Resume Next
    If IsError(UBound(arr_csv)) Then
        TbHeaderLine.Value = 1
    Else
        If TbHeaderLine.Value > (UBound(arr_csv) - LBound(arr_csv) + 1) Then TbHeaderLine.Value = UBound(arr_csv) - LBound(arr_csv) + 1
    End If
    Call ApplyToCbBefore_CbAfter
End Sub


Private Sub BtConvert_Click()
    '変換ボタン
    If IsEmpty(arr_csv) Then
        MsgBox ("開かれているCSVファイルがありません")
        Exit Sub
    End If
    
    Dim Rcd As Variant
    Dim ConvIndex(0 To 1) As Integer ' 何列目から何列目に変換するか
    Dim intHLine As Integer 'ヘッダ行（なかったら0）
    
    intHLine = 0
    If CInt(TbHeaderLine.Value) > intHLine Then intHLine = TbHeaderLine.Value
    
    ' ヘッダ行を分割してLbound参照(LBound(Rcd))も考えたが、空のときに挙動がおかしいのでボツ
   
    ConvIndex(0) = CbBefore.ListIndex
    ConvIndex(1) = CbAfter.ListIndex
    
    For i = (LBound(arr_csv) + intHLine + 1) To UBound(arr_csv)
        Rcd = Split(arr_csv(i), ",")
        Debug.Print (Rcd(ConvIndex(0)) & "→" & Rcd(ConvIndex(1)))
        
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .text = Rcd(ConvIndex(0))
            .Replacement.text = Rcd(ConvIndex(1))
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchByte = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchWildcards = False
            .MatchFuzzy = True
            If CkHighlight Then .Replacement.Highlight = True '蛍光ペンボタンがオンのとき
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
    Next
End Sub

課題

あいまい検索以外の検索を行う場合はコードを書き換える必要がある。別途関数か何かにすべきか……？
読み込み時にリロードボタンを「クリック」させる挙動は何か変な気がする。
置換元の単語が被っていると二重に置換される問題があるので、CSVを予め語句の長い順に

【Word VBA】読み込んだCSVの任意列から任意列へ語句を一括置換（ユーザーフォーム）

やりたいこと

やってみたこと

開発環境

フォーム構成と各パーツの名前

コード

課題

参考にさせていただきました

CSV読み込み

その他