【知らなくても使える】複数セルの書式を一括で変換するマクロツール（Excel VBA）

Option Explicit

'-----（設定値）------------------------
Private Const DATA_START_ROW = 9                '１．書式検索表のデータが開始する行番号
Private Const DATA_START_COL_NUM = 2            '２．書式変換表のデータが開始する列番号
Private Const SETTING_SHEET_NM = "書式変換"		'３．書式変換ツールが存在するシート名

'-----（メッセージ）-------------------
Private Const Msg1 = "一括で書式を変換する対象のファイルを選択してください。"
Private Const Msg2 = "このExcelファイル内で書式変換処理が正常に終了しました。"
Private Const Msg3 = "指定したファイル内で書式変換処理が正常に終了しました。"
Private Const WMsg1 = "検索する文字列を設定してください。"
Private Const WMsg2 = "がファイル内に見つかりませんでした｡ "
Private Const EMsg1 = "予期せぬエラーが発生しました"
'---------------------------------------

Private TgtBook As Workbook
Private BaseSheet As Worksheet
    
'==========================================================
'このファイル内で書式変換ボタンを押した時に実行される処理
'==========================================================
Sub このファイル内で書式変換実行_Click()

    On Error GoTo err
    
    '画面の更新を開始する
    ActiveSheet.Shapes(Application.Caller).Visible = False
    Application.ScreenUpdating = True
    Call Application.Wait(Now + TimeValue("00:00:01"))
    Application.ScreenUpdating = False
    
    Dim msg As String
    Set TgtBook = ActiveWorkbook
    Set BaseSheet = ActiveSheet
    
    '指定した値を検索し、書式変換処理をする
    Call DoReplace(msg)
    
    If msg = "" Then
        MsgBox Msg2
    Else
        MsgBox msg
    End If
    
    Application.CutCopyMode = False
    ActiveSheet.Shapes(Application.Caller).Visible = True
    
    Exit Sub
err:
    MsgBox EMsg1
    ActiveSheet.Shapes(Application.Caller).Visible = True
    
End Sub

'==========================================================
'他ファイルを指定して書式変換ボタンを押した時に実行される処理
'==========================================================
Sub 他ファイルを指定して書式変換実行_Click()

    Dim filePath As String
    Dim fileName As String
    Dim msg As String
    Set BaseSheet = ActiveSheet
    
    '画面の更新を開始する
    ActiveSheet.Shapes(Application.Caller).Visible = False
    Application.ScreenUpdating = True
    
    'ダイアログの表示処理
    filePath = Application.GetOpenFilename(Filefilter:="Microsoft Excelブック,*.xls?,csvファイル,*.csv", Title:=Msg1)
    
    Application.ScreenUpdating = False
    
    If filePath <> "False" Then
        
        'ファイル名のみを取得する
        fileName = Dir(filePath)
        Workbooks.Open (filePath), UpdateLinks:=1

        Set TgtBook = ActiveWorkbook
        
        '指定した値を検索し、書式変換処理をする
        Call DoReplace(msg)
        
        Workbooks(fileName).Close SaveChanges:=True
        
        If msg = "" Then
            MsgBox Msg3
        Else
            MsgBox msg
        End If
        
    'キャンセルが選択された場合はダイアログを閉じる
    Else
        ActiveSheet.Shapes(Application.Caller).Visible = True
        End
    End If
    
    Application.CutCopyMode = False
    ActiveSheet.Shapes(Application.Caller).Visible = True
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    Exit Sub
err:
    MsgBox EMsg1
    ActiveSheet.Shapes(Application.Caller).Visible = True
    
End Sub

'-------------------------
'指定した値を検索し、書式変換処理をする
'-------------------------
Sub DoReplace(msg As String)

    Dim lastRow As Long
    
    'リストの最終行を取得する
    lastRow = BaseSheet.Cells(Rows.Count, DATA_START_COL_NUM).End(xlUp).Row
    
    '書式検索する表内に値がなければメッセージを表示させて処理を終了する
    If lastRow < DATA_START_ROW Then
        MsgBox WMsg1
        End
    End If
    
    Dim tmpSheet As Worksheet
    Dim tgtRng As Range
    Dim i As Long
    
    Dim allMatchFlg As Long                     '完全一致のみ対象にするフラグ
    Dim caseSensitiveFlg As Boolean             '大文字と小文字を区別するフラグ
    Dim byteFlg As Boolean                      '全角と半角を区別するフラグ
    Dim existFlg As Boolean                     '検索ワードが存在するか判断するフラグ
    
    '表内の値の分だけ変換を繰り返す
    For i = DATA_START_ROW To lastRow
        
        Dim searchWord As Variant: searchWord = BaseSheet.Cells(i, DATA_START_COL_NUM).Value     '検索ワード
        Dim tgtSheetNm As String: tgtSheetNm = BaseSheet.Cells(i, DATA_START_COL_NUM + 2).Value    '対象とするシート
        Dim tgtRowCol As String: tgtRowCol = BaseSheet.Cells(i, DATA_START_COL_NUM + 3).Value      '対象とする行/列/範囲
        
        If Trim(BaseSheet.Cells(i, DATA_START_COL_NUM + 4).Value) <> "" Then allMatchFlg = xlWhole _
            Else allMatchFlg = xlPart                                           '完全一致のみ対象にするフラグ
            
        If Trim(BaseSheet.Cells(i, DATA_START_COL_NUM + 5).Value) <> "" Then caseSensitiveFlg = True _
            Else caseSensitiveFlg = False                                       '大文字と小文字を区別するフラグ
            
        If Trim(BaseSheet.Cells(i, DATA_START_COL_NUM + 6).Value) <> "" Then byteFlg = True _
            Else byteFlg = False                                                '全角と半角を区別するフラグ
            
        existFlg = False                                                        '検索ワードが存在するか判断するフラグ
        
        Select Case searchWord
            Case "^", "$", "?", "*", "+", ".", "|", "{", "}", "\", "[", "]", "(", ")"
            searchWord = "~" & searchWord
        End Select
        
        '対象ファイルの全シートを1つずつループして処理する
        For Each tmpSheet In TgtBook.Worksheets
            
            '対象のシートが空白なら全てのシートを対象にし、対象のシートに値がある場合は指定されたシートのみ処理する
            If (tmpSheet.Name <> BaseSheet.Name) And _
                (tgtSheetNm = "" Or (tgtSheetNm <> "" And tgtSheetNm = tmpSheet.Name)) Then
            
                Dim firstCell As String
                
                '対象の行/列/範囲を指定しているかどうかで検索範囲を指定する
                If tgtRowCol <> "" Then
                    
                    Set tgtRng = tmpSheet.Range(tgtRowCol).Find(What:=searchWord, _
                        LookAt:=allMatchFlg, MatchCase:=caseSensitiveFlg, matchbyte:=byteFlg)
                Else
                    
                    Set tgtRng = tmpSheet.Cells.Find(What:=searchWord, _
                        LookAt:=allMatchFlg, MatchCase:=caseSensitiveFlg, matchbyte:=byteFlg)
                End If
                
                If Not (tgtRng Is Nothing) Then
                
                    BaseSheet.Cells(i, DATA_START_COL_NUM + 1).Copy
                    tgtRng.PasteSpecial (xlPasteFormats)
                    
                    firstCell = tgtRng.Address
                    Do
                    
                        If tgtRowCol <> "" Then
                            Set tgtRng = tmpSheet.Range(tgtRowCol).FindNext(tgtRng) ' 対象範囲を指定している場合に次のセルを検索する
                        Else
                            Set tgtRng = tmpSheet.Cells.FindNext(tgtRng) ' 対象範囲を指定していない場合に次のセルを検索する
                        End If
                    
                        If tgtRng.Address = firstCell Then ' 最初のセルと同じセルなら検索を終了する
                            Exit Do
                        Else
                            tgtRng.PasteSpecial (xlPasteFormats)
                        End If
                        
                    Loop
                End If
                
                If Not (tgtRng Is Nothing) Then
                    existFlg = True
                End If
            End If
        Next
        
        '指定した値が存在しない場合はメッセージを出力する
        If Not existFlg And InStr(msg, searchWord) = 0 Then
            msg = msg & "「" & searchWord & "」" & WMsg2 & vbCr
        End If
    Next
        
End Sub

'===========================================
'当ファイルのエクセル内の値を変更した後に実行する処理
'===========================================
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    
    Dim i, iCol, iRow As Long
    Dim selSRow, selERow As Long
    Dim existFlg As Boolean
    
    If Sh.Name <> SETTING_SHEET_NM Then
        Exit Sub
    End If

    selSRow = Range(Selection.Rows(1).Address).Row
    selERow = Range(Selection.Rows(Selection.Rows.Count).Address).Row
    
    iCol = Target.Column
    iRow = Target.Row
    
    If selSRow = selERow Then
        selSRow = iRow
        selERow = iRow
    End If
    
    For iRow = selSRow To selERow
        
        If ActiveSheet.Cells(iRow, DATA_START_COL_NUM + 1).Value <> ActiveSheet.Cells(iRow, DATA_START_COL_NUM).Value And _
            iRow >= DATA_START_ROW Then
            ActiveSheet.Cells(iRow, DATA_START_COL_NUM + 1).Value = ActiveSheet.Cells(iRow, DATA_START_COL_NUM).Value
        End If
    Next
    
End Sub