概要
自分用です。
以前投稿したExcelgrep検索・置換ツールをさらにパワーアップさせました。
・検索＆置換のオプションとして完全一致or部分一致や大文字or小文字などが設定できます。
・また、ファイル検索機能も追加しました。ファイルは複数選択可能です。
※フィルターの解除機能とブックの読み取り専用リンク更新なし機能を追加しました。(2023/10/4)
実施方法の説明
- A列に検索したい文字列を書きます。複数行設定可能です。
- 文字列を置換したい場合はB列に置換した後の単語を書きます。A列の同じ行の単語が置換されます。
- E列に検索対象のファイルのフルパスを書きます。「ファイル名検索」ボタンでファイルパスを追加することもできます。※VBA：Sub ファイル検索()
- 「オプション」シートで検索条件をB列に設定します。
- 検索したい場合は「検索」ボタンを押下します。※VBA：Sub 検索()
検索完了後、F列に検索結果が出力されます。ヒットした単語のみ「シート名：セル内の文字列」で出力されます。 - 置換したい場合は「置換」ボタンを押下します。※VBA：Sub 置換()
「置換したい場合『はい』を選択してください」とポップアップが出るので「はい」を押下してください。
置換完了後、G列に検索結果が出力されます。ヒットした単語のみ「シート名：置換後のセル内の文字列」で出力されます。
- 注意
- マクロの処理が重い場合、Excelが落ちる可能性があります。ほかに開いているファイルがあれば処理の前に保存しておくことをおすすめします。
- E列の中にファイル検索不要の行がある場合、D列に「×」を記載すると検索処理がスキップされます。
シートの作成
Excelシートは2シートです。
「ファイル一覧」シート
「オプション」シート
★「ファイル一覧」シートを作成
「ファイル一覧」シートに表は２つ作成します。
表は５列目にタイトル
６列目以降に値が入ります
表1 検索文字列と置換文字列一覧
A列：検索したい文字列一覧
B列：置換したい文字列一覧(A列に対応)
表2 操作ファイルとその結果
D列：操作の要否（操作不要なら×を記載）
E列：操作したいファイルのフルパス
F列：検索結果(セルのアドレスと値)
G列：置換結果(置換したセルのアドレスと置換後のセルの値)
「ファイル一覧」シート画像
★「オプション」シートを作成
「オプション」シートに表は２つ作成します。
表は4列目にタイトル
5列目以降に値が入ります
※現在設定項目は４つ、順序も値も完全一致しない場合デフォルトの値が設定されます。
表1
A列：設定項目
B列：設定値←この列の値が集計されます。
表2 設定値候補
処理には関係ありませんが、設定値をわかりやすくするために作成します。
図「オプション」シートを参照してください
この図のD列の値がデフォルトとして設定されています。
図「オプション」シート
VBAコード
Moduleは5つ作成します。
Module1
検索ボタンと置換ボタン
※置換は置換して問題ないか確認画面が出ます
Sub 検索()
OpenFile ("検索")
End Sub
Sub 置換()
ans = MsgBox("置換したい場合『はい』を選択してください", vbYesNo)
If ans = vbYes Then
OpenFile ("置換")
End If
End Sub
Module2
ファイル検索
Sub ファイル検索()
Dim ファイル一覧シート As Variant
Set ファイル一覧シート = ThisWorkbook.Sheets("ファイル一覧")
Dim 選択ファイル As Variant
Dim f As Variant
ChDir "C:"
選択ファイル = Application.GetOpenFilename( _
FileFilter:="Excel ファイル (*.xls; *.xlsx),*.xls; *.xlsx", _
MultiSelect:=True)
Dim filei As Integer
If IsArray(選択ファイル) Then
filei = ファイル一覧シート.Range("E10000").End(xlUp).Row + 1
For Each ファイル In 選択ファイル
ファイル一覧シート.Range("E" & filei) = ファイル
filei = filei + 1
Next
End If
End Sub
Module3
ファイルを開く
Function OpenFile(ByRef 操作種別 As String)
Application.ScreenUpdating = False
Dim mySheet As Variant
Set mySheet = ThisWorkbook.Sheets("ファイル一覧")
Dim 操作ブック As Workbook
Dim 結果 As String
'共通の値の設定
Dim 列 As String
If 操作種別 = "検索" Then
列 = "F"
ElseIf 操作種別 = "置換" Then
列 = "G"
End If
On Error GoTo ファイルエラー
'E列に記載されたファイルを開いていく
For file_i = 6 To mySheet.Range("E10000").End(xlUp).Row
結果 = "" '初期化
mySheet.Range(列 & file_i).Value = "検索出来ず"
'検索不要の場合処理を飛ばす
If mySheet.Range("D" & file_i).Value = "×" Then
GoTo skip
End If
'置換-------------------------------------
If 操作種別 = "置換" Then
Set 操作ブック = Workbooks.Open(mySheet.Range("E" & file_i)) '書き込み用に開く
For Each 置換対象シート In 操作ブック.Worksheets
'シートのフィルターをすべて解除する
If 置換対象シート.AutoFilterMode Then
置換対象シート.ShowAllData
End If
結果 = 結果 & ファイル検索置換操作(置換対象シート, 操作種別) '処理の実行
Next '置換対象シート
操作ブック.Close SaveChanges:=True '保存する
ElseIf 操作種別 = "検索" Then
'検索-------------------------------------
Set 操作ブック = Workbooks.Open(mySheet.Range("E" & file_i), UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True) '読み取り専用に開く
For Each 検索対象シート In 操作ブック.Worksheets
If 検索対象シート.AutoFilterMode Then 'フィルターを削除する
検索対象シート.AutoFilterMode = False
End If
結果 = 結果 & ファイル検索置換操作(検索対象シート, 操作種別) '処理の実行
Next '検索対象シート
操作ブック.Close SaveChanges:=False '保存しない
End If
If Len(結果) = 0 Then
結果 = "検索結果0件"
End If
mySheet.Range(列 & file_i).Value = 結果
GoTo skip
ファイルエラー:
mySheet.Range(列 & file_i).Value = "ファイル開かず"
skip:
Next 'file_i
End Function
Module4
検索文字の選択
Function ファイル検索置換操作(ByVal 対象シート As Worksheet, ByRef 操作種別 As String) As String
On Error GoTo エラー
Dim mySheet As Variant
Set mySheet = ThisWorkbook.Sheets("ファイル一覧")
Dim 結果 As String
結果 = ""
Dim 対象セル As Range, tempRng As Range
'検索対象の文字列のループを開始する
For i = 6 To mySheet.Range("A10000").End(xlUp).Row
'空白のセルを検索してしまった場合無限ループになるので飛ばす
If mySheet.Range("A" & i) = "" Then
GoTo continue
End If
結果 = 結果 & 検索置換_オプション設定(対象シート, mySheet.Range("A" & i), _
mySheet.Range("B" & i), 操作種別)
continue:
Next i
ファイル検索置換操作 = 結果
Exit Function
エラー:
ファイル検索置換操作 = "エラー発生"
End Function
Module5
オプションの設定と検索置換操作
Function 検索置換_オプション設定(ByRef 対象シート As Worksheet, ByRef 検索文字 As String, ByRef 置換文字 As String, ByRef 操作種別 As String) As String
On Error GoTo エラー
'検索オプションの設定
Dim オプションシート As Variant
Set オプションシート = ThisWorkbook.Sheets("オプション")
'一致範囲の設定
Dim 完全一致 As Variant
If オプションシート.Range("B5") = "完全一致" Then
完全一致 = 1 'xlWhole 1 検索テキスト全体を検索します。
Else
完全一致 = 2 'xlPart 2 検索テキストの一部を検索します。
End If
'大文字・小文字の区別の設定
Dim 大小文字 As Variant
If オプションシート.Range("B6") = True Then
大小文字 = True
Else
大小文字 = False
End If
'半角・全角区別の設定
Dim 半全角 As Variant
If オプションシート.Range("B7") = True Then
半全角 = True
Else
半全角 = False
End If
'書式一致の設定
Dim 書式一致 As Variant
If オプションシート.Range("B8") = True Then
書式一致 = True
Else
書式一致 = False
End If
'検索の対象の設定
Dim 検索の対象 As Variant
If オプションシート.Range("B8") = "数式" Then
検索の対象 = -4123 'xlFormulas -4123 数式
ElseIf オプションシート.Range("B8") = "コメント" Then
検索の対象 = -4144 'xlComments -4144 コメント
Else
検索の対象 = -4163 'xlValues -4163 値
End If
''''検索の実施
Dim 結果 As String
結果 = ""
Dim 検索結果セル As Range
Set 検索結果セル = 対象シート.Cells.Find(検索文字, _
SearchOrder:=xlByRows, _
LookAt:=完全一致, _
MatchCase:=大小文字, _
MatchByte:=半全角, _
SearchFormat:=書式一致, _
LookIn:=検索の対象)
'2つ目以降の検索
Dim 対象セル As Range, tempRng As Range
' 2個以上の場合に備え、検索結果を一時保存
Set tempRng = 検索結果セル
' 条件にあったセルが見つからなければNothingでループを抜ける
Do While Not 検索結果セル Is Nothing
If 操作種別 = "置換" Then
検索結果セル.Value = Replace(検索結果セル.Value, 検索文字, 置換文字)
End If
結果 = 結果 & 対象シート.Name & 検索結果セル.Address & " : " & 検索結果セル & vbCrLf
' FindNextで検索を継続
Set 検索結果セル = 対象シート.Cells.FindNext(検索結果セル)
'検索結果セル＝Nothingでエラーが発生するためここで対処
If 検索結果セル Is Nothing Then
Exit Do
End If
' これを忘れると無限ループになるので注意！
If 検索結果セル.Address = tempRng.Address Then
Exit Do
End If
Loop
検索置換_オプション設定 = 結果
Exit Function
エラー:
ファイル検索操作 = "エラー発生"
End Function