エクセルGREP置換

Option Explicit

 

Const SEARCH_WORD_CLM As Long = 1 '置換対象語句記入列
Const REPLACE_WORD_CLM As Long = 2 '置換後の語句記入列
Const SEARCH_METHOD_ROW As Long = 2 '検索対象記入行
Const SEARCH_METHOD_CLM As Long = 3 '検索対象記入列
Const OPTION_CLM As Long = 4 'オプション記入列
Const WHOLE_MATCH_ROW As Long = 5 '完全一致記入行
Const MATCH_CASE_ROW As Long = 6 '大文字小文字区別記入行
Const MATCH_BYTE_ROW As Long = 7 '全角半角区別記入行
Const SEARCH_FOLDER_PATH_CLM As Long = 6 '検索対象フォルダパス記入列
Const SEARCH_FILE_NAME_CLM As Long = 7 '検索対象ファイル名記入列
Const SEARCH_RESULT_CLM As Long = 8 '検索実行結果記入列

 

Dim configSht, resultSht, ws As Worksheet '検索実行シート・検索結果シート
Dim searchBookName As String '検索Book名
Dim result_row As Long '結果記入行
Dim result_clm As Long '結果記入列
Dim in_search_method As Long '検索対象
Dim in_look_at As Long '完全一致部分一致判定用
Dim in_match_case As Boolean '大文字小文字区別判定用
Dim in_match_byte As Boolean '全角半角区別判定用
Dim accept_xlsx As Boolean '拡張子判定用(xlsx)
Dim accept_xlsm As Boolean '拡張子判定用(xlsm)
Dim accept_xls As Boolean '拡張子判定用(xls)
Dim accept_extention As Boolean '拡張子判定結果
Dim path_cnt As Long 'ファイルパス取得用カウント
Dim folder_cnt As Long 'フォルダループ用カウント
Dim search_folder_path As String '検索フォルダパス
Dim search_file_path As String '検索ファイルパス
Dim update_sts As Long 'close更新ステータス
Dim in_update As Boolean '置換確認判定用

 

 

Sub Folder_Replace()

 

Application.ScreenUpdating = False

 

'初期設定
Call Init_Params

 

'フォルダ選択
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = 0 Then
End 'ダイアログでキャンセルボタンが押された場合は処理を終了
End If
search_folder_path = .SelectedItems(1)
End With

 

MsgBox "Start"

 

'結果クリア
Call Crear_Result

 

'検索対象フォルダパス・検索対象ファイル名記入
Call Get_File_Path(search_folder_path)

 

'フォルダループ開始
Do While configSht.Cells(folder_cnt, SEARCH_FOLDER_PATH_CLM) <> ""

 

search_file_path = configSht.Cells(folder_cnt, SEARCH_FOLDER_PATH_CLM) & "\" & configSht.Cells(folder_cnt, SEARCH_FILE_NAME_CLM)

 

'拡張子判定
update_sts = 0
Call Extention_Check(search_file_path, accept_extention)
If accept_extention Then
Workbooks.Open search_file_path
searchBookName = ActiveWorkbook.Name

 

'Grep置換実行
Call Grep_Replace_Execute
If update_sts > 0 Then
Workbooks(searchBookName).Close saveChanges:=True
configSht.Cells(folder_cnt, SEARCH_RESULT_CLM).Value = "置換完了"
Else
Workbooks(searchBookName).Close saveChanges:=False
configSht.Cells(folder_cnt, SEARCH_RESULT_CLM).Value = "置換スッキプ"
End If
Else
configSht.Cells(folder_cnt, SEARCH_RESULT_CLM).Value = "拡張子が対象外のため置換対象外となりました"
End If

 

folder_cnt = folder_cnt + 1
Loop
'フォルダループ終了

 

resultSht.Activate

 

Application.ScreenUpdating = True

 

MsgBox "End"

 

End Sub

 

 

 

Sub File_Replace()

 

Application.ScreenUpdating = False

 

'初期設定
Call Init_Params

 

'ファイル選択
search_file_path = Application.GetOpenFilename()
If search_file_path = "False" Then 'ダイアログでキャンセルボタンが押された場合は処理を終了
End
End If

 

'拡張子判定
update_sts = 0
Call Extention_Check(search_file_path, accept_extention)
If Not accept_extention Then
MsgBox "拡張子が対象外のファイルです"
End
End If

 

MsgBox "Start"

 

'結果クリア
Call Crear_Result

 

Workbooks.Open search_file_path
searchBookName = ActiveWorkbook.Name

 

'検索対象フォルダパス・検索対象ファイル名記入
configSht.Cells(2, SEARCH_FOLDER_PATH_CLM) = Workbooks(searchBookName).Path
configSht.Cells(2, SEARCH_FILE_NAME_CLM) = Workbooks(searchBookName).Name

 

'Grep置換実行
Call Grep_Replace_Execute

 

If update_sts > 0 Then
Workbooks(searchBookName).Close saveChanges:=True
configSht.Cells(2, SEARCH_RESULT_CLM).Value = "置換完了"
Else
Workbooks(searchBookName).Close saveChanges:=False
configSht.Cells(2, SEARCH_RESULT_CLM).Value = "置換スッキプ"
End If
resultSht.Activate

 

Application.ScreenUpdating = True

 

MsgBox "End"

 

End Sub

 

Sub Init_Params()

 

'変数指定
path_cnt = 1
folder_cnt = 2
result_row = 1
result_clm = 1

 

Set configSht = Workbooks("エクセルGrep検索・Grep置換ツール.xlsm").Worksheets("置換実行")
Set resultSht = Workbooks("エクセルGrep検索・Grep置換ツール.xlsm").Worksheets("置換結果")

 

'オプション設定
'検索対象
If configSht.Cells(SEARCH_METHOD_ROW, SEARCH_METHOD_CLM) = "数式" Then
in_search_method = xlFormulas
ElseIf configSht.Cells(SEARCH_METHOD_ROW, SEARCH_METHOD_CLM) = "値" Then
in_search_method = xlValues
ElseIf configSht.Cells(SEARCH_METHOD_ROW, SEARCH_METHOD_CLM) = "メモ" Then
in_search_method = xlNotes
ElseIf configSht.Cells(SEARCH_METHOD_ROW, SEARCH_METHOD_CLM) = "コメント" Then
in_search_method = xlCommentsThreaded
End If
'完全一致/部分一致
If configSht.Cells(WHOLE_MATCH_ROW, OPTION_CLM) = "ON" Then
in_look_at = xlWhole
Else
in_look_at = xlPart
End If
'大文字小文字区別
If configSht.Cells(MATCH_CASE_ROW, OPTION_CLM) = "ON" Then
in_match_case = True
Else
in_match_case = False
End If
'全角半角区別
If configSht.Cells(MATCH_BYTE_ROW, OPTION_CLM) = "ON" Then
in_match_byte = True
Else
in_match_byte = False
End If

 

'拡張子判定
If configSht.Cells(10, OPTION_CLM) = "対象" Then
accept_xlsx = True
Else
accept_xlsx = False
End If

 

If configSht.Cells(11, OPTION_CLM) = "対象" Then
accept_xlsm = True
Else
accept_xlsm = False
End If

 

If configSht.Cells(12, OPTION_CLM) = "対象" Then
accept_xls = True
Else
accept_xls = False
End If

 

'置換確認
If configSht.Cells(15, OPTION_CLM) = "ON" Then
in_update = True
Else
in_update = False
End If

 

End Sub

 

Sub Crear_Result()

 

'検索結果クリア
resultSht.Activate
If Not resultSht.Range("A2", Range("A2").SpecialCells(xlLastCell)).row = 1 Then
resultSht.Range("A2", Range("A2").SpecialCells(xlLastCell)).ClearContents
End If

 

'検索対象フォルダパス・検索対象ファイル名クリア
configSht.Activate
If Not configSht.Range("F2", Range("F2").SpecialCells(xlLastCell)).row = 1 Then
configSht.Range("F2", Range("F2").SpecialCells(xlLastCell)).ClearContents
End If

 

End Sub

 

Sub Grep_Replace_Execute()

 

Dim searchResalt As Range '検索結果
Dim search_word As String '検索対象語句
Dim search_word_row As Long '行(検索対象語句)
Dim sheets_count As Long 'シート数
Dim firstAddress As String '初回アドレス
Dim first_search As Boolean '初回検索フラグ
Dim searchSht As Worksheet '検索対象シート
Dim replace_word As String '置換対象語句
Dim wk_replace_value As String '置換用変数
Dim rc As Integer
Dim Wupdate_string As String

 

resultSht.Activate

 

'シートループ開始
For sheets_count = 1 To Workbooks(searchBookName).Sheets.Count
Set searchSht = Workbooks(searchBookName).Worksheets(sheets_count)
search_word_row = 2
'検索判定ループ開始
Do While configSht.Cells(search_word_row, SEARCH_WORD_CLM) <> ""
search_word = configSht.Cells(search_word_row, SEARCH_WORD_CLM) '置換対象
replace_word = configSht.Cells(search_word_row, REPLACE_WORD_CLM) '置換後
If TypeName(search_word) <> "Boolean" Then
With searchSht.Cells
Set searchResalt = .Find(search_word, LookIn:=in_search_method, Lookat:=in_look_at, MatchCase:=in_match_case, MatchByte:=in_match_byte)
If Not searchResalt Is Nothing Then

 

firstAddress = searchResalt.Address
first_search = True

 

'検索実施ループ開始
Do
If Not first_search And searchResalt.Address = firstAddress Then
Exit Do
Else
If in_update = True Then
Application.ScreenUpdating = True
Wupdate_string = searchResalt
Wupdate_string = Replace(Wupdate_string, search_word, replace_word)
rc = MsgBox("更新語句：" & search_word & " ⇒ " & replace_word & vbCrLf & "更新前テキスト：" & searchResalt & vbCrLf & "更新後テキスト：" & Wupdate_string, vbYesNo + vbQuestion, "確認")
'メッセージボックスで「更新のはい・いいえ」を表示
If rc <> vbYes Then '「いいえ」を選択
'MsgBox "更新語句：" & search_word & " ⇒ " & replace_word & vbCrLf & vbCrLf & "更新前テキスト：" & searchResalt & vbCrLf & "更新後テキスト：" & Wupdate_string & vbCrLf & "更新をスキップします"
GoTo P_1
Else
'MsgBox "更新語句：" & search_word & " ⇒ " & replace_word & vbCrLf & vbCrLf & "更新前テキスト：" & searchResalt & vbCrLf & "更新後テキスト：" & Wupdate_string & vbCrLf & "更新します"
End If
Application.ScreenUpdating = False
End If
update_sts = update_sts + 1
result_row = result_row + 1
resultSht.Cells(result_row, result_clm).Value = search_word '検索対象語句
resultSht.Cells(result_row, result_clm + 1).Value = replace_word '置換後語句
resultSht.Cells(result_row, result_clm + 2).Value = Workbooks(searchBookName).Path 'ファイルパス
resultSht.Cells(result_row, result_clm + 3).Value = Workbooks(searchBookName).Name 'ファイル名
resultSht.Cells(result_row, result_clm + 4).Value = searchSht.Name 'シート名
resultSht.Cells(result_row, result_clm + 5).Value = searchResalt.Address 'セル位置
resultSht.Cells(result_row, result_clm + 6).Value = searchResalt.Formula 'セル内容(置換前)
'置換実施
wk_replace_value = searchResalt.Formula
searchSht.Cells(searchResalt.row, searchResalt.column).Formula = Replace(wk_replace_value, search_word, replace_word, , , vbTextCompare)
resultSht.Cells(result_row, result_clm + 7).Value = searchResalt.Formula 'セル内容(置換後)
'ハイパーリンク
resultSht.Hyperlinks.Add Anchor:=Cells(result_row, result_clm + 8), Address:=search_file_path, SubAddress:=searchSht.Name & "!" & searchResalt.Address
End If
P_1:

 

first_search = False
Set searchResalt = searchSht.Cells.FindNext(searchResalt)

 

'置換後の再検索抑止
If searchResalt Is Nothing Then
Exit Do
End If

 

Loop
'検索実施ループ終了

 

End If
End With
End If
search_word_row = search_word_row + 1
Loop
'検索判定ループ終了

 

Next sheets_count
'シートループ終了

 

End Sub

 

 

 

'[参考]サブフォルダを含めてファイル一覧を取得する（Dir関数の再帰呼び出し）
'https://www.moug.net/tech/exvba/0060088.html
Sub Get_File_Path(Path As String)
Dim buf As String, f As Object
buf = Dir(Path & "\*.xls*")
Do While buf <> ""
path_cnt = path_cnt + 1
configSht.Cells(path_cnt, SEARCH_FOLDER_PATH_CLM).Value = Path
configSht.Cells(path_cnt, SEARCH_FILE_NAME_CLM).Value = buf
buf = Dir()
Loop
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(Path).SubFolders
Call Get_File_Path(f.Path)
Next f
End With
End Sub

 

'[参考]拡張子を確実に取得する
'https://www.moug.net/tech/exvba/0060053.html
Sub Extention_Check(targetPath As String, extention_check_result As Boolean)
Dim extensionData As String
Dim periodPosition As Long

 

periodPosition = InStrRev(targetPath, ".")
extensionData = LCase(Mid(targetPath, periodPosition + 1))

 

extention_check_result = False

 

If accept_xlsx And extensionData = "xlsx" Then
extention_check_result = True
End If
If accept_xlsm And extensionData = "xlsm" Then
extention_check_result = True
End If
If accept_xls And extensionData = "xls" Then
extention_check_result = True
End If

 

End Sub