概要
自分用です。
★文字列検索したセルを削除するかセルを挿入します。
★挿入するセルの範囲はコードを修正して操作したいシートに応じて変えていきます。
Module5「オプションの設定と検索置換操作」の下記の対象セルの範囲を修正してください
'セルの範囲を指定 使用ごとにここを修正する
Set 対象セル = Range(～）
★今回はファイルを保存せず、開いたまま処理が終了します。
そのため処理を取り消したい場合はファイルを保存しないで閉じれば、VBA実行前に戻ります。
★現在挿入したセルには「マクロ挿入セル(列数)」が記入されます
挿入後置換できるようにそうしています。
シートの作成
Excelシートは2シートです。
「ファイル一覧」シート
「オプション」シート
★「ファイル一覧」シートを作成
「ファイル一覧」シートに表は２つ作成します。
表は５列目にタイトル
６列目以降に値が入ります
表1 検索文字列と置換文字列一覧
A列：検索したい文字列一覧
B列：操作内容の記載(「挿入」か「削除」のみ。エラーの場合エラーメッセージがB列に記載される)
表2 操作ファイルとその結果
D列：操作の要否（操作不要なら×を記載）
E列：操作したいファイルのフルパス
F列：検索結果(セルのアドレスと値)
G列：置換結果(置換したセルのアドレスと置換後のセルの値)
「ファイル一覧」シート画像
★「オプション」シートを作成
「オプション」シートに表は２つ作成します。
表は4列目にタイトル
5列目以降に値が入ります
※現在設定項目は４つ、順序も値も完全一致しない場合デフォルトの値が設定されます。
表1
A列：設定項目
B列：設定値←この列の値が集計されます。
表2 設定値候補
処理には関係ありませんが、設定値をわかりやすくするために作成します。
※D列の値がデフォルトとして設定されています。
詳しくはVBA テンプレート ExcelGrep検索＆置換デラックスを参照ください。
VBAコード
Moduleは5つ作成します。
Module1
検索ボタンとセルボタン
※置換は置換して問題ないか確認画面が出ます
Sub 検索()
OpenFile ("検索")
End Sub
Sub InsertDelete操作()
ans = MsgBox("InsertDelete操作したい場合『はい』を選択してください", 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 ファイル一覧シート As Variant
Set ファイル一覧シート = ThisWorkbook.Sheets("ファイル一覧")
Dim 操作ブック As Workbook
Dim 結果 As String
'共通の値の設定
Dim 列 As String
If 操作種別 = "検索" Then
列 = "F"
ElseIf 操作種別 = "置換" Then
列 = "G"
End If
On Error GoTo エラー
For filei = 6 To ファイル一覧シート.Range("E10000").End(xlUp).Row
ファイル一覧シート.Range(列 & filei).Value = "検索出来ず"
If Not ファイル一覧シート.Range("D" & filei).Value = "×" Then
Workbooks.Open ファイル一覧シート.Range("E" & filei)
Set 操作ブック = ActiveWorkbook
'処理の実行
結果 = ファイル検索置換操作(操作ブック, 操作種別)
ファイル一覧シート.Range(列 & filei).Value = 結果
'ファイルは保存せず開いたままにする
End If '"×"
GoTo skip
エラー:
ファイル一覧シート.Range(列 & filei).Value = "ファイル開かず"
skip:
Next filei
End Function
Module4
検索文字の選択
Function ファイル検索置換操作(ByRef 操作ブック As Workbook, ByRef 操作種別 As String) As String
On Error GoTo エラー
Dim 一覧シート As Variant
Set 一覧シート = ThisWorkbook.Sheets("ファイル一覧")
Dim 結果 As String
結果 = ""
Dim 対象シート As Worksheet
Dim 対象セル As Range, tempRng As Range
Dim InsertOrDelete As String
For Each 対象シート In 操作ブック.Worksheets
For i = 6 To 一覧シート.Range("A10000").End(xlUp).Row
'空白のセルを検索してしまった場合無限ループになるので飛ばす
If 一覧シート.Range("A" & i) = "" Then
GoTo continue
End If
If 操作種別 = "置換" Then
InsertOrDelete = 一覧シート.Range("B" & i)
If Not (InsertOrDelete = "挿入" Or InsertOrDelete = "削除") Then
'エラーであることを伝えるためにセルを赤くする
一覧シート.Range("B" & i) = "「挿入」か「削除」を入力してください。処理できませんでした。"
End If
End If
結果 = 結果 & 検索置換_オプション設定(対象シート, 一覧シート.Range("A" & i), _
操作種別, InsertOrDelete)
continue:
Next i
Next 対象シート
If Len(結果) = 0 Then
結果 = "検索結果0件"
End If
ファイル検索置換操作 = 結果
Exit Function
エラー:
ファイル検索置換操作 = "エラー発生"
End Function
Module5
オプションの設定と検索置換操作
Function 検索置換_オプション設定(ByRef 対象シート As Worksheet, _
ByRef 検索文字 As String, ByRef 操作種別 As String, ByRef InsertOrDelete 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
Dim tempString As String
tempString = "tempString\s7dh5fi5oua5rhg;oainzl7xk5ivi7of46nkl"
Dim printNum As Integer
' 2個以上の場合に備え、検索結果を一時保存
Set tempRng = 検索結果セル
' 条件にあったセルが見つからなければNothingでループを抜ける
Do While Not 検索結果セル Is Nothing
If 操作種別 = "置換" Then
'セルの範囲を指定 使用ごとにここを修正する
'検索したセルからCtrl Shift + 矢印→した値
Set 対象セル = Range(対象シート.Cells(検索結果セル.Row, 検索結果セル.Column), _
対象シート.Cells(検索結果セル.Row, 検索結果セル.End(xlToRight).Column))
If InsertOrDelete = "挿入" Then
対象セル.Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow '下方向にシフト&下と同じ書式を適用
printNum = 0
For col = 検索結果セル.Column To 検索結果セル.End(xlToRight).Column
printNum = printNum + 1
対象シート.Cells(検索結果セル.Row - 1, col) = "マクロ挿入セル" & printNum
Next
'検索結果が無限ループにならないよう一旦置換する
検索結果セル.Value = Replace(検索結果セル.Value, 検索文字, tempString)
ElseIf InsertOrDelete = "削除" Then
対象セル.Delete Shift:=xlUp '削除後上にシフト
End If
Set 検索結果セル = 対象シート.Cells.Find(検索文字, _
SearchOrder:=xlByRows, _
LookAt:=完全一致, _
MatchCase:=大小文字, _
MatchByte:=半全角, _
SearchFormat:=書式一致, _
LookIn:=検索の対象)
Else
'検索の場合
結果 = 結果 & 対象シート.Name & 検索結果セル.Address & " : " & 検索結果セル & vbCrLf
' FindNextで検索を継続
Set 検索結果セル = 対象シート.Cells.FindNext(検索結果セル)
' これを忘れると無限ループになるので注意！
If 検索結果セル.Address = tempRng.Address Then
Exit Do
End If
End If
'検索結果セル＝Nothingでエラーが発生するためここで対処
If 検索結果セル Is Nothing Then
Exit Do
End If
Loop
'挿入で一時的に置換した値を元に戻す
If InsertOrDelete = "挿入" Then
対象シート.UsedRange.Replace What:=tempString, Replacement:=検索文字
End If
検索置換_オプション設定 = 結果
Exit Function
エラー:
ファイル検索操作 = "エラー発生"
End Function