【Excel VBA】複数セルの書式一括変換ツール(コピペですぐ使える)

日常業務を行うにあたって、エクセル内である文字を検索してその文字を置換することはよくあるかと思います。

 

しかし、複数のセルで書式のみ(文字色を赤色にしたり、背景色を黄色にする等)を変更したい場合はExcelの通常機能では実現できなかったので、何か楽な方法はないかなと色々考えていました。

 

そこで、エクセルの表に検索する文字列と適用させる書式を指定して実行すると、指定した全ての文字列があるセルの書式を一括で変換してくれるツールをマクロで作成しましたので、是非ご活用頂けたらと思います。

 

ちなみに、Excelファイル内の限定した範囲において複数の文字列などをクリック一回で置換するツールも作っています。

以下になりますので、よろしければ参照ください。

 

『複数セルの書式一括変換ツール』の概要

エクセルの表内に検索する文字列変換後の書式を記載した状態で、当該ファイル内、または対象のファイルをダイアログで指定すると、そのファイル内の指定したシートを対象に検索する文字列が含まれているセルの書式を変換してくれます。

 

ExcelにてVBAコードを記載したマクロを作成し、ボタン(図形)をクリックすることでマクロを実行させて、書式の一括変換処理を実施します

 

当ツールの使用方法

基本的な機能、操作方法の説明

1.複数セルの書式一括変換ツールのVBAコードを含んだExcelファイル(***.xlsm)を作成して、そのExcelファイルを開きます。

 

2.「検索する文字列」と「変換後の書式」、「対象のシート」、「対象の行/列/範囲」等をそれぞれ入力します。

対象のシート

検索/書式変換の対象とするシート名を入力してください。
※値がない場合は、全てのシートを対象にして検索/置換します

対象の行/列/範囲

検索/書式変換の対象となる行、列または範囲を指定してください。
※値がない場合は、全ての範囲を対象にして検索/置換します

記載例
「1:10」 →1行目から10行目までを対象
「A:D」 →A列からD列までを対象
「A1:G5」 →A1からG5の範囲を対象

 

3.書式変換ボタン(2種類あります)を押した後に、対象のファイルを選択します。

「このファイル内で書式変換実行」を押した場合は、このツールが入っているExcelファイル内を対象として一括で書式を変換する処理を実行します。

 

「他ファイルを指定して書式変換実行」を押した場合は、ファイル選択ダイアログが開かれて選択したExcelファイルを対象として書式変換処理を実行します。

 

指定した範囲内で指定した「検索する文字列」が「変換後の書式」で設定した書式情報に変換されています。

 

留意事項

検索する際の条件に関して、必要に応じて以下を設定してください。

Option:条件の適用

それぞれの検索条件に対して、「完全一致のみを対象とする」、「大文字と小文字を区別する」、「半角と全角を区別する」を指定することができます。

 

また、実行した結果として、”指定した文字列が入っているセルの書式が全て正常に変換されたか”、”ファイル内に指定した文字列に存在しないものがあったか” これらのどちらかのメッセージが表示されますので確認してください。

 

使用する際の事前準備

このページの下部にある「Excelファイルのサンプル」からExcelファイルを取得し、「準備の手順」内にあるVBAコードを取得したExcelファイルに記載して保存すれば、すぐに当ツールを使用できます。

 

以下にその手順を説明していきます。

 

準備の手順

1.サンプルのダウンロードはこちら」からサンプル(Excelファイル)をダウンロードし、ファイルを開きます。

※インターネットにあるマクロファイルをダウンロードすることはセキュリティ上リスクがあるので、マクロ無しExcelファイルを公開しています

2.ダウンロードしたExcelファイルの上部にあるリボンの「開発」タブから「visual basic」を選択して、VBE(visual basic for application)を起動させます。

 

リボンに「開発」タブが表示されていない場合は、以下を参照ください。

 

3.「ThisWorkbook」をダブルクリックします。

 

4.表示されている右側の欄(エディター)にVBAコードを記載します。

 

VBAのソースコードはこちら

以下のVBAコードをコピーして、「ThisWorkbook」内のエディターに貼り付けます。

※VBAコードの右上のアイコンをクリックするとソースコードをコピーできます

Option Explicit

'-----(設定値)------------------------
Private Const DATA_START_ROW = 9                '1.書式検索表のデータが開始する行番号
Private Const DATA_START_COL_NUM = 2            '2.書式変換表のデータが開始する列番号
Private Const SETTING_SHEET_NM = "書式変換"		'3.書式変換ツールが存在するシート名

'-----(メッセージ)-------------------
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

 

4.ファイルを保存する際は「Excelマクロ有効ブック」を選択して、保存します。

 

5.右端にある「このファイル内で書式変換実行」と記載された図形に処理「このファイル内で書式変換実行_Click」のマクロを設定します。

 

その右にある「他ファイルを指定して書式変換実行」と記載された図形に処理「他ァイルを指定して書式変換実行_Click」のマクロを設定します。

 

5でマクロ登録した図形にカーソルを当てて、指の形になっていたら正常に設定できています。

 

これで事前準備は完了です。

あとは「当ツールの使用方法」で記載された方法でツールを実行できます。

 

また、このようなExcelVBAを用いた業務効率化を行うときに、以下の書籍が初心者向けでとても参考になると思いますので、良かったらご参照ください。

 

なお、当マクロの開発環境として、OSは “Windows10” 、Excelのバージョンは Microsoft Office 365″ で行っており、当環境では動作確認ができていますが、他のすべての環境で正常に動作するかは確認できていません。

 

正常に動作しない場合は、コメントいただければ幸いです。

 

当ツールのダウンロードはこちら

下記よりExcelファイルをダウンロードして、記事の途中にありました VBAのソースコードをツール内に組み込んで使用してください。

 

【Excel VBA】複数セルの書式一括変換ツール

※インターネットにあるマクロファイルをダウンロードすることはセキュリティ上リスクがあるので、マクロ無しExcelファイルを公開しています

 

他に要望等ありましたら、可能な限り改修等を対応しますのでコメント頂ければと思います

 

<このツールが『結構使える!』と思ったら、下のグッドボタンを押していただけたら幸いです>

コメントを残す

CAPTCHA