リストに基づいた記号置換(ExcelVBA)

ゆーしゃん
2021.11.28
175 views

概要

「置換リスト」シートに記載した「置換前文字」を「置換後文字」に置換する

プログラムを作成した理由

「ExcelVBAが多少書けます！」(if、forが分かる程度)と意気揚々と入社して数日後…
とあるCSV変換作業マニュアルを確認していたところ、

「検索と置換」(「Ctrl」+「H」キー)にて以下記号を置換する
という作業がありました。

※左(置換前)を右(置換後)記号に置換

Ⅰ　→　1
Ⅱ　→　2
Ⅲ　→　3
Ⅳ　→　4
Ⅴ　→　5
Ⅵ　→　6
Ⅶ　→　7
Ⅷ　→　8
Ⅸ　→　9
Ⅹ　→　10
①　→　[1]
②　→　[2]
③　→　[3]
④　→　[4]
⑤　→　[5]
⑥　→　[6]
⑦　→　[7]
⑧　→　[8]
⑨　→　[9]
⑩　→　[10]

これを毎日毎日手動で対応するのか…
と考えるだけで憂鬱になっていたのですが、

「そういえば置換ってExcelVBAで自動化出来るのかな…？」

とググったのがきっかけです。
~~今振り返ると、入社数日で自動化着手とか生意気な社員ですね←~~

実装内容

「置換リスト」シートに置換前文言、置換後文言、置換適応範囲を記載
※29行目以降にリストを追加すればVBAコードを修正せずに置換する事が可能

例)
29行目に
・A列「Σ」
・B列「◆」
・C列「A」
・D列「C」
と記載すれば、A列～C列内の「Σ」を「◆」に置換

が追加可能です

置換したいシートに移動し、「置換マクロ」を実行

「置換リスト」シートに記載した内容通りに置換されている事を確認し、作業終了！

「①～⑩はA～B列置換」と記載した為、C列は置換されていない
「Ⅰ～ⅩはA列のみ置換」と記載した為、A列のみ置換されている
「♪★☆◇□▽△はC22～C26セルのみ置換」と記載した為、C27～C28セルは置換されていない

ソースコード

Option Explicit

'概要：アクティブシートに対し、「置換リスト」表に従って置換する
Sub 置換マクロ()

    
    '定数定義
    Const LIST_SHEETNAME As String = "置換リスト"
    Const ERRCODE_01 As String = "エラーコード:01"
    Const ERRCODE_99 As String = "エラーコード:99"
        
    '変数定義
    Dim BeforeText As String
    Dim AfterText As String
    Dim StartArea As String
    Dim EndArea As String
    Dim CompArea As String
    Dim LowsCount As Long
    Dim IntCheck As String
    Dim StrCheck As String
    Dim IntAreaStart As Integer
    Dim Sheet_CheckFlg As Boolean
    Dim ws As Worksheet
    Dim ColumnErrerMsg As String
    
    'ループカウンタ
    Dim i As Integer
    
    '「置換リスト」シート存在チェックフラグ初期化
    Sheet_CheckFlg = False
    
    '「置換リスト」シート存在チェックフラグ更新
    For Each ws In Worksheets
    
        If ws.Name = LIST_SHEETNAME Then
            '存在する場合、フラグ変更
            Sheet_CheckFlg = True
        End If
        
    Next ws
    
    '「置換リスト」シート存在チェック
    If Not Sheet_CheckFlg Then
        MsgBox (LIST_SHEETNAME & "シートを追加してください。")
        Exit Sub
    End If
    
    '空白チェック
    If ThisWorkbook.Worksheets(LIST_SHEETNAME).Range("A2").Value = "" Then
        MsgBox ("置換リスト内容を設定してください。")
        Exit Sub
    End If
        
    '置換リスト行数を取得
    LowsCount = ThisWorkbook.Worksheets(LIST_SHEETNAME).Range("A1").End(xlDown).Row
    
    '高速化処理開始
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    '置換リスト行数分ループ(項目名は含まない)
    For i = 2 To LowsCount
        
        '置換対象テキスト格納
        BeforeText = ThisWorkbook.Worksheets(LIST_SHEETNAME).Cells(i, 1).Value
        
        '置換後テキスト格納
        AfterText = ThisWorkbook.Worksheets(LIST_SHEETNAME).Cells(i, 2).Value
        
        '置換範囲格納
        StartArea = ThisWorkbook.Worksheets(LIST_SHEETNAME).Cells(i, 3).Value
        EndArea = ThisWorkbook.Worksheets(LIST_SHEETNAME).Cells(i, 4).Value
        
        'エラーメッセージ作成
        ColumnErrerMsg = vbNewLine & "処理を中止します" & vbNewLine & "エラー箇所:" & i & "列目"
        
        '空白チェック
        If StartArea = "" Then
            MsgBox ("置換開始範囲を設定してください。" & ColumnErrerMsg & vbNewLine & ERRCODE_01)
            Exit Sub
        End If
        
        '文字列チェック
        '例)AA、A20等のアルファベット数をチェック
        StrCheck = Mid(StartArea, 2, 1)
        If (StrCheck Like "[A-Z]") Then
            IntAreaStart = 3
        Else
            IntAreaStart = 2
        End If
        
        '数値チェック内容を格納
        IntCheck = Mid(StartArea, IntAreaStart, Len(StartArea))
        
        '置換範囲テキスト作成
        If EndArea = "" Then
            CompArea = StartArea
        Else
            CompArea = StartArea & ":" & EndArea
        End If
               
        '置換実行でエラーが発生した場合、ErrerMsgにスキップする
        On Error GoTo ErrerMsg
        
            '列指定(E列全て等)か範囲指定(E2～E8等)かで分岐
            If IsNumeric(IntCheck) Then
            
                '範囲内置換
                'xlPart=検索文字列を含むセルを検索：xlByRows=行を横方向に検索してから、次の行に移動：MatchCase=大文字と小文字を区別する：SearchFormat=書式変更無：ReplaceFormat=書式変更無
                ActiveSheet.Range(CompArea).Replace What:=BeforeText, Replacement:=AfterText, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, ReplaceFormat:=False
                
            Else
            
                '列全体置換
                ActiveSheet.Columns(CompArea).Replace What:=BeforeText, Replacement:=AfterText, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, ReplaceFormat:=False

            End If
            
        On Error GoTo 0
        
    Next
    
    '高速化処理初期化
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    '完了メッセージ
    MsgBox ("完了致しました！")
    
    'ErrerMsgに移行しないよう終了させる
    Exit Sub
    
'置換処理エラー発生時、実行
ErrerMsg:
        
    '高速化処理初期化
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    '範囲設定想定外エラー
    MsgBox ("置換実行時にエラーが発生しました。エラー行の範囲設定を見直してください。" & ColumnErrerMsg & vbNewLine & ERRCODE_99)
    Exit Sub

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

Option Explicit

'概要：アクティブシートに対し、「置換リスト」表に従って置換する

Sub 置換マクロ()

'定数定義

Const LIST_SHEETNAME As String = "置換リスト"

Const ERRCODE_01 As String = "エラーコード:01"

Const ERRCODE_99 As String = "エラーコード:99"

'変数定義

Dim BeforeText As String

Dim AfterText As String

Dim StartArea As String

Dim EndArea As String

Dim CompArea As String

Dim LowsCount As Long

Dim IntCheck As String

Dim StrCheck As String

Dim IntAreaStart As Integer

Dim Sheet_CheckFlg As Boolean

Dim ws As Worksheet

Dim ColumnErrerMsg As String

'ループカウンタ

Dim i As Integer

'「置換リスト」シート存在チェックフラグ初期化

Sheet_CheckFlg = False

'「置換リスト」シート存在チェックフラグ更新

For Each ws In Worksheets

If ws.Name = LIST_SHEETNAME Then

'存在する場合、フラグ変更

Sheet_CheckFlg = True

End If

Next ws

'「置換リスト」シート存在チェック

If Not Sheet_CheckFlg Then

MsgBox (LIST_SHEETNAME & "シートを追加してください。")

Exit Sub

End If

'空白チェック

If ThisWorkbook.Worksheets(LIST_SHEETNAME).Range("A2").Value = "" Then

MsgBox ("置換リスト内容を設定してください。")

Exit Sub

End If

'置換リスト行数を取得

LowsCount = ThisWorkbook.Worksheets(LIST_SHEETNAME).Range("A1").End(xlDown).Row

'高速化処理開始

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

'置換リスト行数分ループ(項目名は含まない)

For i = 2 To LowsCount

'置換対象テキスト格納

BeforeText = ThisWorkbook.Worksheets(LIST_SHEETNAME).Cells(i, 1).Value

'置換後テキスト格納

AfterText = ThisWorkbook.Worksheets(LIST_SHEETNAME).Cells(i, 2).Value

'置換範囲格納

StartArea = ThisWorkbook.Worksheets(LIST_SHEETNAME).Cells(i, 3).Value

EndArea = ThisWorkbook.Worksheets(LIST_SHEETNAME).Cells(i, 4).Value

'エラーメッセージ作成

ColumnErrerMsg = vbNewLine & "処理を中止します" & vbNewLine & "エラー箇所:" & i & "列目"

'空白チェック

If StartArea = "" Then

MsgBox ("置換開始範囲を設定してください。" & ColumnErrerMsg & vbNewLine & ERRCODE_01)

Exit Sub

End If

'文字列チェック

'例)AA、A20等のアルファベット数をチェック

StrCheck = Mid(StartArea, 2, 1)

If (StrCheck Like "[A-Z]") Then

IntAreaStart = 3

Else

IntAreaStart = 2

End If

'数値チェック内容を格納

IntCheck = Mid(StartArea, IntAreaStart, Len(StartArea))

'置換範囲テキスト作成

If EndArea = "" Then

CompArea = StartArea

Else

CompArea = StartArea & ":" & EndArea

End If

'置換実行でエラーが発生した場合、ErrerMsgにスキップする

On Error GoTo ErrerMsg

'列指定(E列全て等)か範囲指定(E2～E8等)かで分岐

If IsNumeric(IntCheck) Then

'範囲内置換

'xlPart=検索文字列を含むセルを検索：xlByRows=行を横方向に検索してから、次の行に移動：MatchCase=大文字と小文字を区別する：SearchFormat=書式変更無：ReplaceFormat=書式変更無

ActiveSheet.Range(CompArea).Replace What:=BeforeText, Replacement:=AfterText, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, ReplaceFormat:=False

Else

'列全体置換

ActiveSheet.Columns(CompArea).Replace What:=BeforeText, Replacement:=AfterText, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, ReplaceFormat:=False

End If

On Error GoTo 0

'高速化処理初期化

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

'完了メッセージ

MsgBox ("完了致しました！")

'ErrerMsgに移行しないよう終了させる

Exit Sub

'置換処理エラー発生時、実行

ErrerMsg:

'高速化処理初期化

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

'範囲設定想定外エラー

MsgBox ("置換実行時にエラーが発生しました。エラー行の範囲設定を見直してください。" & ColumnErrerMsg & vbNewLine & ERRCODE_99)

Exit Sub

End Sub

感想

当時ExcelVBA初心者の私(if、for分が軽く分かるくらい)でしたが、
ExcelVBAに関する情報はググれば大量にあるので何とか実装出来ました。

こんな素人ツールでも職場からは
「え！早速自動ツール作成されたのですか！？流石マクロ使いですね！！！」
と前評判を落とさずに済みました(笑)

本ツールは「プログラムが何をやっているかが想像しやすい」という事もあり、
一気に定着致しました。

最初に取り組む自動化は
「作成者、使用者、管理者の三者が一見して内容が分かる自動化」がおススメかもしれませんね