擬似継承＆コールバック関数（イベント）で定番の処理を共通化
RelaxTools Addin というソフトを公開しております。
Excelのアドインソフトですが、以下のような機能のマクロが100以上存在します。
- （処理したい）セルを選択する
- 選択したセルに対して処理を行う
ただこれだけなのですがソフトとして公開となるといろいろ共通的に必要になるものがあります。
- そもそもActiveCellがあるか？
- 選択されているのはシェイプか？セルか？
- 選択エリアが複数ないか？
- 非常に大量のセルが選択されていないか？
- セルが連結されていないか？
- 行や列が非表示やフィルタされていないか？
- 選択されたセルの中で文字列のあるセルのみを抽出する。
- 画面表示がチラチラしないようにApplication.ScreenUpdatingで制御する。
などなど盛りだくさんあり、これらを100以上も実装してたらたいへんなことになります。
そこで選択セルの処理を行うフレームワークを作成、必要な処理のみを記述すればよいようにしました。
この例では、選択されたセルの値を小文字に変換する機能となります。
basExecute.bas
機能の呼び出し部分です。New して唯一のメソッド Run を実行しています。
basExecute.bas
Option Explicit
'--------------------------------------------------------------
' 小文字変換(SelectionFrameWork使用)
'--------------------------------------------------------------
Sub execSelectionToLower()
Dim obj As SelectionToLower
Set obj = New SelectionToLower
obj.Run
Set obj = Nothing
End Sub
SelectionToLower.cls
文字列を小文字化する実装部分です。
前半のお約束記述部分が擬似継承です。親クラスのRunメソッドを実行します。
その後、「前処理」「主処理」「後処理」の順に実行されます。
「主処理」は選択されているセルの数だけ実行されます。
内容的には StrConv コマンドで小文字しているだけです。
エラーなどで処理を中断したい場合には、引数のCancelにTrueをセットします。
SelectionToLower.cls
Option Explicit
'--- ここから SelectionFrameWork を使用する場合のお約束記述 ---
Private WithEvents SFWork As SelectionFrameWork
Private Sub Class_Initialize()
Set SFWork = New SelectionFrameWork
End Sub
Private Sub Class_Terminate()
Set SFWork = Nothing
End Sub
Public Sub Run()
SFWork.Run
End Sub
'--- ここまで SelectionFrameWork を使用する場合のお約束記述 ---
'----------------------------------------------------------------------------------------------------
' 前処理(UOC)
'----------------------------------------------------------------------------------------------------
Private Sub SFWork_SelectionInit(Cancel As Boolean)
'処理があれば書く。キャンセルしたい場合には Cancel = true とする
End Sub
'----------------------------------------------------------------------------------------------------
' 主処理(UOC)
'----------------------------------------------------------------------------------------------------
Private Sub SFWork_SelectionMain(r As Range, Cancel As Boolean)
On Error GoTo e
'セルの値を小文字にする
r.Value = StrConv(r.Value, vbLowerCase)
Exit Sub
e:
Cancel = True
End Sub
'----------------------------------------------------------------------------------------------------
' 後処理(UOC)
'----------------------------------------------------------------------------------------------------
Private Sub SFWork_SelectionTerm()
'処理があれば書く
End Sub
SelectionFrameWork.cls
定番の処理を共通化したフレームワーク「SelectionFramework」です。
処理の流れや雑多なチェック処理が記述されており、RaiseEventにより、呼び元のコールバック関数を実行します。
この例ではシンプルにするためにUndoの処理や処理中メッセージなどが省かれています。:-)
SelectionFrameWork.cls
'--------------------------------------------------------------
' Selectionに含まれるCellの数だけ処理を行うフレームワーク
'--------------------------------------------------------------
Option Explicit
'メッセージタイトル
Private Const C_TITLE As String = "SelectionFrameWork"
'セルの選択セル警告数
Private Const C_MAX_CELLS As Long = 100000
'初期化イベント
Public Event SelectionInit(ByRef Cancel As Boolean)
'メインイベント
Public Event SelectionMain(ByRef r As Range, ByRef Cancel As Boolean)
'終了イベント
Public Event SelectionTerm()
'処理実行部
Public Sub Run()
'変数宣言
Dim r As Range
Dim Cancel As Boolean
Dim sel As Range
Dim colMerge As Collection
On Error GoTo ErrHandle
'キャンセルの初期化
Cancel = False
Dim blnRange As Boolean
blnRange = False
Select Case True
Case ActiveWorkbook Is Nothing
Case ActiveCell Is Nothing
Case Selection Is Nothing
Case TypeOf Selection Is Range
blnRange = True
Case Else
End Select
If blnRange Then
Else
MsgBox "選択範囲が見つかりません。", vbCritical, C_TITLE
Exit Sub
End If
'使われているセルと現在選択セルのAND部分のみ処理する。
Set sel = Intersect(ActiveSheet.UsedRange, Selection)
'重複する選択が無い場合終了。
If sel Is Nothing Then
Exit Sub
End If
Dim ret As VbMsgBoxResult
If sel.CountLarge > C_MAX_CELLS Then
ret = MsgBox("大量のセルが選択されています。処理に時間がかかりますが続行しますか？", vbInformation + vbOKCancel + vbDefaultButton2, C_TITLE)
If ret = vbCancel Then
Exit Sub
End If
End If
'---------------------------
'初期化イベント
'---------------------------
RaiseEvent SelectionInit(Cancel)
'キャンセルの場合
If Cancel Then
Exit Sub
End If
Set colMerge = New Collection
Dim strAddress As String
Application.ScreenUpdating = False
For Each r In sel
''フィルタおよび非表示対策。
If r.Rows.Hidden Or r.Columns.Hidden Then
'フィルタまたは非表示の行・列の処理は行わない。
Else
'マージセル対策
strAddress = r.MergeArea(1, 1).Address
Dim e As Range
On Error Resume Next
Set e = Nothing
Set e = colMerge(strAddress)
On Error GoTo 0
'アドレスが登録されていない場合イベントを起こす
If err.Number = 0 And Not (e Is Nothing) Then
Else
'---------------------------
'メインイベント
'---------------------------
If IsEmpty(r.Value) Or IsError(r.Value) Then
Else
RaiseEvent SelectionMain(r, Cancel)
If Cancel Then
Exit For
End If
End If
colMerge.Add r, strAddress
End If
End If
Next
Application.ScreenUpdating = True
'---------------------------
'終了イベント
'---------------------------
Application.ScreenUpdating = False
RaiseEvent SelectionTerm
Application.ScreenUpdating = True
Exit Sub
ErrHandle:
MsgBox "エラーが発生しました。", vbOKOnly, C_TITLE
End Sub
大分複雑な記述ですが、一度フレームワークを作ってしまえば、必要な部分の実装だけでかなりリッチなプログラムが作成可能です。
他のソースをごらんになりたい方はこちらへ
Excelを便利にする250以上の機能を体系化したアドインはこちらです。
「RelaxTools Addin」窓の杜大賞受賞ソフト
http://software.opensquare.net/relaxtools/