■ オリジナル関数用のプロトタイプ
例外処理については、
こちらで説明する方式を採用しています
シートはオブジェクト変数に格納した方が効率がよいため
Private 変数で作成しておき、初期処理
(ProcInit) 内で設定しています
また、マクロ内ではシートが保護解除された状態で実行されて欲しいため、初期処理内で保護解除しています
直後に
UserInterfaceOnly:=True のオプションを使用して保護を行うと、マクロ内からはセル操作を行うことができるので保護し忘れを防ぐ利点もありましたが、オブジェクトが操作できないという欠点が見つかったため、終了処理
(ProcExit) 内で保護する従来通りの方法に戻しています
エラーが発生している場合の終了処理は
True を追加で指定しています
すでにエラーが発生している場合、終了処理内でエラーが発生すると、デバッグウィンドウが表示されてしまうので、
On Error Resume Next でエラーが発生しても無視するようにしています
処理中は画面更新を停止しています
メッセージダイアログが表示されたときもこの状態だと、ダイアログを動かした際に残像が残るなど表示が正しく行われないため、メッセージダイアログを表示する前後で画面更新の再開と再停止を行う処理
(ShowMessage) を標準として用意しています
また、標準処理としてセル範囲取得
(GetRange) を用意しています
列記号を使用せずにセルを範囲指定する場合には
Cells(x, y).Resize(xsize, ysize) とするか
Range(Cells(x1, y1), Cells(x2, y2) とします
ただ
o_sheet.Range(Cells(1, 1), Cells(5, 300) と書いてしまうと
Range と
Cells は別のシートを意味してしまい、新旧の
Excel ブックが混在するような処理でエラーが発生してしまう可能性があります
ただ、
Cells(x, y).Resize(xsize, ysize) の指定は分かりにくい場合があるので、
GetRange(x1, y1, x2, y2) で範囲指定できるような標準処理も用意しています
Option Explicit
Private Const DF_TITLE As String = "Excel雛形"
Private o_sheet_main As Worksheet '' ワークシート
'*------------------------------------------------------------------------------
'* メイン処理
'*------------------------------------------------------------------------------
Public Sub ProcMain()
Dim st_step As String '' ステップ番号
On Error GoTo ErrRoutine
st_step = "0010"
Call ProcInit
ExitRoutine:
st_step = "9000"
Call ProcExit
Exit Sub
ErrRoutine:
Call ProcError("ProcMain", st_step, True)
Call ProcExit(True)
End Sub
'*------------------------------------------------------------------------------
'* 初期処理
'*------------------------------------------------------------------------------
Private Sub ProcInit()
'' 画面更新停止
Application.ScreenUpdating = False
'' 確認メッセージ抑制解除
Application.DisplayAlerts = True
'' ステータスバークリア
Application.StatusBar = False
Set o_sheet_main = ThisWorkbook.Worksheets("Sheet1")
'' シート保護解除
o_sheet_main.Unprotect
End Sub
'*------------------------------------------------------------------------------
'* 終了処理
'*------------------------------------------------------------------------------
Private Sub ProcExit(Optional ByVal bln_err As Boolean = False)
'' エラーが発生した場合の終了処理の場合
If (bln_err) Then
'' 終了処理内でエラーが発生しても無視する
On Error Resume Next
End If
'' シート保護
o_sheet_main.Protect
Set o_sheet_main = Nothing
'' 確認メッセージ抑制解除
Application.DisplayAlerts = True
'' ステータスバークリア
Application.StatusBar = False
'' 画面更新再開
Application.ScreenUpdating = True
End Sub
'*------------------------------------------------------------------------------
'* エラー処理
'*------------------------------------------------------------------------------
Private Sub ProcError(ByVal st_proc As String, ByVal st_step As String, _
Optional ByVal bln_main As Boolean = False)
'' エラー発生の呼び出し履歴を作成する
If (Left$(Err.Source, 3) <> " → ") Then
Err.Source = " → " & st_proc & "." & st_step
Else
Err.Source = " → " & st_proc & "." & st_step & Err.Source
End If
If (bln_main) Then
'' システムエラーを表示する
Call ShowMessage("予期しないエラーが発生しました。" & vbCrLf & vbCrLf & _
Err.Description & " (" & Err.Number & ")" & vbCrLf & vbCrLf & _
Mid$(Err.Source, 3), vbCritical)
Else
'' 呼び出し元の関数でエラーを発生させる
Call Err.Raise(Err.Number, Err.Source, Err.Description)
End If
End Sub
'*------------------------------------------------------------------------------
'* セル範囲取得
'*------------------------------------------------------------------------------
Private Function GetRange(ByVal o_sheet As Worksheet, _
ByVal i_row1 As Long, ByVal i_col1 As Long, _
Optional ByVal i_row2 As Long = 1, _
Optional ByVal i_col2 As Long = 1) As Range
If (i_row2 > 1) Then
i_row2 = i_row2 - i_row1 + 1
End If
If (i_col2 > 1) Then
i_col2 = i_col2 - i_col1 + 1
End If
Set GetRange = o_sheet.Cells(i_row1, i_col1).Resize(i_row2, i_col2)
End Function
'*------------------------------------------------------------------------------
'* メッセージ表示
'*------------------------------------------------------------------------------
Private Function ShowMessage(ByVal Prompt As String, _
Optional ByVal Buttons As VbMsgBoxStyle = vbExclamation, _
Optional ByVal Title As String = DF_TITLE) As VbMsgBoxResult
'' メッセージを表示
Application.ScreenUpdating = True
ShowMessage = MsgBox(Prompt, Buttons, Title)
Application.ScreenUpdating = False
End Function