sutefu7.com

VBA でフォルダパスを指定して、ファイルレベルの検索と置換ツールを作ってみる

Excel VBA

大量にある Excel ファイルに対して、確認と修正作業を入れなければいけないときとかに欲しくなるやつですね～。

目次

目次
動作イメージ
サンプルフォルダ構成
チェックされる側、Excel ファイル（aaa.xlsx 等）
チェックする側、検索＆置換ツール（test.xlsm）
駄文

動作イメージ

f:id:sutefu7:20190910121621p:plain

サンプルフォルダ構成

以下です。

test.xlsm
target/
  + aaa.xlsx
  + bbb.xlsx
  + ccc.xlsx

チェックされる側、Excel ファイル（aaa.xlsx 等）

A	B
バナナ	80
リンゴ	180
ミカン	280
ナシ	380
リンゴ	80
モモ	480

チェックする側、検索＆置換ツール（test.xlsm）

見た目は適当に作ります。検索ボタンと置換ボタンの処理は以下です。動作テストはテスト用のファイル等でやった方が安心かもです。特に置換処理は書き換えて保存してしまいますので、できればコード内容を理解してからの方がいいかもです。

' 検索ボタン
Private Sub CommandButton1_Click()
    
    Dim wk As Workbook
    Dim sht As Worksheet
    
    Set wk = ThisWorkbook
    Set sht = wk.Sheets("Sheet1")
    
    Dim path As String
    Dim key As String
    
    path = sht.Range("B3").Value
    key = sht.Range("C7").Value
    
    ' 事前チェック
    If path = "" Or Dir(path, vbDirectory) = "" Then
        MsgBox "存在するフォルダパスを入力してください。"
        Set sht = Nothing
        Set wk = Nothing
        Exit Sub
    End If
    
    If key = "" Then
        MsgBox "検索ワードを入力してください。"
        Set sht = Nothing
        Set wk = Nothing
        Exit Sub
    End If
    
    ' 処理開始
    sht.Range("D11").Value = ""
    sht.Range("D12").Value = ""
    
    ' 検索
    Call ClearData(sht)
    Call Search(path, key, sht)
    Call DrawLine(sht)
    
    ' 結果
    sht.Range("D11").Value = "検索完了"
    sht.Range("D12").Value = "該当: " + CStr(GetResultCount(sht)) + " 件"
    
    Set sht = Nothing
    Set wk = Nothing
    
End Sub

' 検索結果のクリア
Private Sub ClearData(ByVal sht As Worksheet)
    
    Dim lastRow As Long
    lastRow = sht.Cells(Rows.Count, 6).End(xlUp).Row
    If lastRow < 2 Then
        lastRow = 2
    End If
    
    sht.Range("F2:I" + CStr(lastRow)).Clear
    
End Sub

' 検索処理
Private Sub Search(ByVal path As String, ByVal srcKey As String, ByVal workSht As Worksheet)
    
    Dim index As Long: index = 2
    Dim readWk As Workbook
    Dim readSht As Worksheet
    Dim found As Range
    
    Dim file As String
    file = Dir(path + "\*.xlsx")
    Do While file <> ""
        
        ' 読み取り専用で開く（グラフシート等は対象外にしたいので、Sheets ではなく Worksheets を指定）
        Set readWk = Workbooks.Open(path + "\" + file, , True)
        For Each readSht In readWk.Worksheets
            
            Dim first As String
            Set found = readSht.Cells.Find(What:=srcKey, LookIn:=xlValues, LookAt:=xlPart)
            If Not found Is Nothing Then
                
                ' 最初の検索位置に戻るまで、繰り返し検索
                first = found.Address
                Do
                    ' ファイル名
                    workSht.Range("F" + CStr(index)).Value = file
                    
                    ' シート名
                    workSht.Range("G" + CStr(index)).Value = readSht.name
                    
                    ' セル
                    workSht.Range("H" + CStr(index)).Value = found.Address
                    
                    ' 値
                    workSht.Range("I" + CStr(index)).Value = found.Value
                    
                    ' 次の位置をセットしておく
                    index = index + 1
                    
                    ' 次の位置を探す
                    Set found = readSht.Cells.FindNext(found)
                    If found Is Nothing Then
                        Exit Do
                    End If
                    
                    
                Loop Until found.Address = first
                
            End If
        Next
        
        readWk.Close
        Set readSht = Nothing
        Set readWk = Nothing
        
        ' バッファーにためた次のファイルパスを取得
        file = Dir()
    Loop
    
    
End Sub

' 罫線を引く
Private Sub DrawLine(ByVal sht As Worksheet)
    
    Dim lastRow As Long
    lastRow = sht.Cells(Rows.Count, 6).End(xlUp).Row
    If lastRow < 2 Then
        Exit Sub
    End If
    
    sht.Range("F2:I" + CStr(lastRow)).Borders.LineStyle = xlContinuous
    
End Sub

' 結果の件数を返却
Private Function GetResultCount(ByVal sht As Worksheet)
    
    Dim lastRow As Long
    lastRow = sht.Cells(Rows.Count, 6).End(xlUp).Row
    
    If lastRow = 1 Then
        GetResultCount = 0
    Else
        GetResultCount = lastRow - 1
    End If
    
End Function

' 置換ボタン
Private Sub CommandButton2_Click()
    
    If MsgBox("置換処理は、検索ワードを見つけた場合、置換してそのまま上書き保存してしまいます。処理を行いますか？", vbYesNo + vbQuestion, "確認") = vbNo Then
        Exit Sub
    End If
    
    Dim wk As Workbook
    Dim sht As Worksheet
    
    Set wk = ThisWorkbook
    Set sht = wk.Sheets("Sheet1")
    
    Dim path As String
    Dim srcKey As String
    Dim repKey As String
    
    path = sht.Range("B3").Value
    srcKey = sht.Range("C7").Value
    repKey = sht.Range("C8").Value
    
    ' 事前チェック
    If path = "" Or Dir(path, vbDirectory) = "" Then
        MsgBox "存在するフォルダパスを入力してください。"
        Set sht = Nothing
        Set wk = Nothing
        Exit Sub
    End If
    
    If srcKey = "" Or repKey = "" Then
        
        Dim msg As String
        
        If srcKey = "" Then
            msg = "検索ワード"
        End If
        
        If repKey = "" Then
            If msg = "" Then
                msg = "置換ワード"
            Else
                msg = msg + "と置換ワード"
            End If
        End If
        
        msg = msg + "を入力してください。"
        MsgBox msg
        Set sht = Nothing
        Set wk = Nothing
        Exit Sub
    End If
    
    ' 処理開始
    sht.Range("D11").Value = ""
    sht.Range("D12").Value = ""
    
    ' 置換
    Call ClearData(sht)
    Call MyReplace(path, srcKey, repKey, sht)
    Call DrawLine(sht)
    
    ' 結果
    sht.Range("D11").Value = "置換完了"
    sht.Range("D12").Value = "該当: " + CStr(GetResultCount(sht)) + " 件"
    
    Set sht = Nothing
    Set wk = Nothing
    
End Sub

' 置換処理
Private Sub MyReplace(ByVal path As String, ByVal srcKey As String, ByVal repKey As String, ByVal workSht As Worksheet)
    
    Dim index As Long: index = 2
    Dim targetWk As Workbook
    Dim targetSht As Worksheet
    Dim found As Range
    
    Dim file As String
    file = Dir(path + "\*.xlsx")
    Do While file <> ""
        
        ' 開く（グラフシート等は対象外にしたいので、Sheets ではなく Worksheets を指定）
        Set targetWk = Workbooks.Open(path + "\" + file)
        For Each targetSht In targetWk.Worksheets
            
            Dim first As String
            Set found = targetSht.Cells.Find(What:=srcKey, LookIn:=xlValues, LookAt:=xlPart)
            If Not found Is Nothing Then
                
                ' 最初の検索位置に戻るまで、繰り返し検索
                first = found.Address
                Do
                    ' ファイル名
                    workSht.Range("F" + CStr(index)).Value = file
                    
                    ' シート名
                    workSht.Range("G" + CStr(index)).Value = targetSht.name
                    
                    ' セル
                    workSht.Range("H" + CStr(index)).Value = found.Address
                    
                    ' 値を部分置換
                    found.Value = Replace(found.Value, srcKey, repKey)
                    workSht.Range("I" + CStr(index)).Value = found.Value
                    
                    ' 次の位置をセットしておく
                    index = index + 1
                    
                    ' 次の位置を探す
                    Set found = targetSht.Cells.FindNext(found)
                    If found Is Nothing Then
                        Exit Do
                    End If
                    
                    
                Loop Until found.Address = first
                
            End If
        Next
        
        targetWk.Save
        targetWk.Close
        Set targetSht = Nothing
        Set targetWk = Nothing
        
        ' バッファーにためた次のファイルパスを取得
        file = Dir()
    Loop
    
    
End Sub

駄文

長いですが、やってることは部分部分ではシンプルなやつです。検索と結果は、左右並びよりも上下並びの方がいいかもしれませんね。