フォルダ内のエクセルの特定の文字列をすべて置換する

大型案件で仕様変更による名称変更があったりする際にまとめて変えてしまいたい人向けのマクロです。

置換だけいいってのはよくある話かと思いますが、いっそのこと色も変えたら楽じゃね？
ってことで簡単なマクロです。

まあ、以下に同じ作業を繰り返さないかが肝心だと思っているので。

Option Explicit

Sub ReplaceTextWithColor()
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim cell As Range
    Dim findText As String
    Dim replaceText As String
    Dim pos As Long
    Dim colorMode As String
    Dim fontColor As Long
    Dim redValue As Integer, greenValue As Integer, blueValue As Integer
    Dim fullPath As String

    ' === 入力値取得 ===
    With ThisWorkbook.Sheets(1)
        folderPath = Trim(.Range("C2").Value)
        findText = Trim(.Range("C3").Value)
        replaceText = Trim(.Range("C4").Value)
        colorMode = LCase(Trim(.Range("C5").Value))
        
        Select Case colorMode
            Case "赤"
                fontColor = RGB(255, 0, 0)
            Case "青"
                fontColor = RGB(0, 0, 255)
            Case "黒"
                fontColor = RGB(0, 0, 0)
            Case "custom"
                redValue = Val(.Range("C6").Value)
                greenValue = Val(.Range("C7").Value)
                blueValue = Val(.Range("C8").Value)

                If Not IsValidRGB(redValue, greenValue, blueValue) Then
                    MsgBox "RGB値は0～255の範囲で指定してください。" & vbCrLf & _
                           "現在の値: R=" & redValue & ", G=" & greenValue & ", B=" & blueValue, vbCritical
                    Exit Sub
                End If

                fontColor = RGB(redValue, greenValue, blueValue)
            Case Else
                MsgBox "色指定が不正です。" & vbCrLf & _
                       "「赤」「青」「黒」または「custom」を指定してください。", vbExclamation
                Exit Sub
        End Select
    End With

    ' === フォルダチェック ===
    If folderPath = "" Then
        MsgBox "フォルダパスが空です。C2セルを確認してください。", vbExclamation
        Exit Sub
    End If

    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    If Dir(folderPath, vbDirectory) = "" Then
        MsgBox "フォルダが存在しません: " & folderPath, vbExclamation
        Exit Sub
    End If

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    fileName = Dir(folderPath & "*.xls*")

    Do While fileName <> ""
        fullPath = folderPath & fileName

        ' 自分自身は処理しない
        If fullPath <> ThisWorkbook.FullName Then
            On Error Resume Next
            Set wb = Workbooks.Open(fullPath, ReadOnly:=False)
            On Error GoTo 0

            If Not wb Is Nothing Then
                If TypeName(wb) = "Workbook" Then
                    ProcessWorkbook wb, findText, replaceText, fontColor, fileName
                    wb.Close SaveChanges:=True
                Else
                    Debug.Print "[スキップ] Workbookではない形式: " & fileName
                    wb.Close False
                End If
            Else
                Debug.Print "[失敗] 開けなかったファイル: " & fileName
            End If
        End If

        fileName = Dir()
    Loop

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    MsgBox "すべての処理が完了しました！", vbInformation
End Sub

Private Sub ProcessWorkbook(wb As Workbook, findText As String, replaceText As String, fontColor As Long, fileName As String)
    Dim ws As Worksheet
    Dim cell As Range
    Dim pos As Long

    On Error GoTo HandleSheetError

    For Each ws In wb.Worksheets
        If Not ws.ProtectContents Then
            If Not ws.UsedRange Is Nothing Then
                For Each cell In ws.UsedRange
                    If Not IsError(cell.Value) And VarType(cell.Value) = vbString Then
                        Do
                            pos = InStr(cell.Value, findText)
                            If pos > 0 Then
                                cell.Value = Application.WorksheetFunction.Substitute(cell.Value, findText, replaceText, 1)
                                cell.Characters(Start:=pos, Length:=Len(replaceText)).Font.Color = fontColor
                            End If
                        Loop While pos > 0 And InStr(cell.Value, findText) > 0
                    End If
                Next cell
            End If
        Else
            Debug.Print "[スキップ] 保護されたシート: " & ws.Name & " in " & fileName
        End If
    Next ws

    Exit Sub

HandleSheetError:
    Debug.Print "[エラー] シート処理中にエラー: " & fileName & ", シート: " & ws.Name
    Resume Next
End Sub

Private Function IsValidRGB(r As Integer, g As Integer, b As Integer) As Boolean
    IsValidRGB = (r >= 0 And r <= 255) And (g >= 0 And g <= 255) And (b >= 0 And b <= 255)
End Function