検索したセルを削除または挿入

## 概要
自分用です。
★文字列検索したセルを削除するかセルを挿入します。
★挿入するセルの範囲はコードを修正して操作したいシートに応じて変えていきます。
Module5「オプションの設定と検索置換操作」の下記の対象セルの範囲を修正してください
　'セルの範囲を指定　使用ごとにここを修正する
　Set 対象セル = Range(～）

★今回はファイルを保存せず、開いたまま処理が終了します。
そのため処理を取り消したい場合はファイルを保存しないで閉じれば、VBA実行前に戻ります。
★現在挿入したセルには「マクロ挿入セル(列数)」が記入されます
挿入後置換できるようにそうしています。

## シートの作成
Excelシートは2シートです。
「ファイル一覧」シート
「オプション」シート

★「ファイル一覧」シートを作成

「ファイル一覧」シートに表は２つ作成します。
表は５列目にタイトル
６列目以降に値が入ります

表1　検索文字列と置換文字列一覧
A列：検索したい文字列一覧
B列：操作内容の記載(「挿入」か「削除」のみ。エラーの場合エラーメッセージがB列に記載される)

表2　操作ファイルとその結果
D列：操作の要否（操作不要なら×を記載）
E列：操作したいファイルのフルパス
F列：検索結果(セルのアドレスと値)
G列：置換結果(置換したセルのアドレスと置換後のセルの値)

「ファイル一覧」シート画像
![VBA 2022-07-06 224228.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/2550991/17229ab8-561f-2190-d51c-10dc6478117b.png)


★「オプション」シートを作成

「オプション」シートに表は２つ作成します。
表は4列目にタイトル
5列目以降に値が入ります
※現在設定項目は４つ、順序も値も完全一致しない場合デフォルトの値が設定されます。

表1　
A列：設定項目
B列：設定値←この列の値が集計されます。

表2　設定値候補
処理には関係ありませんが、設定値をわかりやすくするために作成します。
※D列の値がデフォルトとして設定されています。
詳しくは[VBA テンプレート　ExcelGrep検索＆置換デラックス](https://qiita.com/cuvskr/items/dd284037197da251b413)を参照ください。

## 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


```