ExcelVBAでの業務システムの開発

ExcelVBAでの業務システムの開発

ExcelVBA+Accessでの業務システム開発ノウハウ

ExcelVBAでグーグルカレンダーのような時刻入力フォームを作る

スマホ版のグーグルカレンダーアプリには、時刻を直感的に入力できるフォームがあります。
今回はExcelVBAで同じような機能を持つフォームを作ります。

f:id:atsushi_ota:20200825161528p:plain
図 グーグルカレンダー時間入力フォーム

完成物

f:id:atsushi_ota:20200825171625g:plain
図 時刻入力フォームの操作

この時刻入力フォームの主な仕様としては以下のとおりです。

  • アナログ時計を模した文字盤上でマウスカーソルを移動させると時分が動く
  • 文字盤上でクリックすると時分が確定
  • 文字盤の文字上でクリックすると、クリックした文字で時分が確定
  • 時分はドラムロール式UIを採用し、1分、5分、10分単位での調整が可能
  • 確定ボタンを押すと時刻が入力される
  • 現在時刻ボタンを押すことで素早く現在時刻の入力が可能
  • キーボードだけでも時刻の入力が可能

時刻入力フォームを作る

まず、ユーザーフォームを新しく作成します。
フォーム名は「Frm時刻入力」にします。
f:id:atsushi_ota:20201003212130p:plain

フォームに以下のオブジェクトを配置していきます。
各オブジェクトの名前や位置関係は下の図のとおりにしてください。
色はお好みでどうぞ。
フレームが時計の文字盤となります。

  • コマンドボックス(Btn) 3つ
  • フレーム(Fra) 1つ
  • テキストボックス(Txt) 2つ
  • ラベル(Lbl) 1つ

f:id:atsushi_ota:20201003212540p:plain

ドラムロール部の作成

先ほど作成したボタンとフレームの間に15個のラベルを配置します。

背景色がピンクのラベルが「時」と「分」を表示するものです。
ピンクラベルの上側にある赤文字のラベルをクリックすることで「時分」を減少でき、下側にある青文字のラベルは、「時分」を増加することができます。

各ラベルの名前は下の図のとおりとし、時分増減ラベルについては「Lbl時加算1」、「Lbl分加算2」、「Lbl時減算3」のようにしてください。
f:id:atsushi_ota:20201003213602p:plain

文字盤部の作成

フレームの上に24個のラベル1個のボタンを配置します。
ラベルの名前は「Lbl文字盤1」から「Lbl文字盤24」とし、円形に配置します。
また、各ラベルのCaptionは下図のとおりにしてください。

これでフォームに各オブジェクトの配置は完了しました。
f:id:atsushi_ota:20201003222544p:plain

コーディング

標準モジュールとクラスモジュールを追加します。
標準モジュール名は「Mod共通処理」、クラスモジュールは「Cls時刻入力」にします。
あとは各モジュールに以下のコードをコピペすることで時刻入力フォームが使用可能となります。
f:id:atsushi_ota:20201003230236p:plain

シートモジュール(Sheet1)

'A1セルをダブルクリックで時刻入力フォームが表示し、A1セルに時刻が入力される
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    With Range("A1")
        If Target.Address = .Address Then
            Cancel = True
            .Value = Frm時刻入力.Getフォームで選択した時間(.Value)
            Unload Frm時刻入力
            Exit Sub
        End If
    End With
End Sub

標準モジュール(Mod共通処理)

Public Function 左からn文字削除(文字列 As String, n As Long) As String
    左からn文字削除 = Right(文字列, Len(文字列) - n)
End Function
Public Function 右からn文字削除(文字列 As String, n As Long) As String
    右からn文字削除 = Left(文字列, Len(文字列) - n)
End Function
Public Function is文字が数値か(文字 As String) As Boolean
    If InStr("1234567890", 文字) <> 0 Then
        is文字が数値か = True
    Else
        is文字が数値か = False
    End If
End Function

フォームモジュール(Frm時刻入力)

Private CtrlLbl文字盤(1 To 24) As New Cls時刻入力
Private CtrlLbl分加算(1 To 3) As New Cls時刻入力
Private CtrlLbl分減算(1 To 3) As New Cls時刻入力
Private CtrlLbl時加算(1 To 3) As New Cls時刻入力
Private CtrlLbl時減算(1 To 3) As New Cls時刻入力

Const C_黒 As Long = 0   'RGB(0, 0, 0)
Const C_赤 As Long = 255  'RGB(255,0,0)
Const C_灰 As Long = 12566463  'RGB(191, 191, 191)
Const C_白 As Long = 16777215  'RGB(255, 255, 255)
Const 午前と午後との境目の距離 As Long = 55

Public Enum e時分選択モード
    mode選択停止 = 0
    mode時選択 = 1
    mode分選択 = 2
End Enum

Private Type type文字盤中心座標
    x As Single
    y As Single
End Type

Private 選択モード As e時分選択モード
Private 時分の初期値 As Date
Private 現在設定されている時分 As Date
Private 文字盤上にマウスポインタがある As Boolean
Public Function Getフォームで選択した時間(ByVal 時分の初期値_ As Date) As String
    '文字盤ラベルの共通処理の準備
    Dim i As Long
    For i = LBound(CtrlLbl文字盤, 1) To UBound(CtrlLbl文字盤, 1)
        Set CtrlLbl文字盤(i).Lbl文字盤 = Me("Lbl文字盤" & i)
    Next
    
     'ドラムロールラベルの共通処理の準備
    Dim k As Long
    For k = LBound(CtrlLbl分加算, 1) To UBound(CtrlLbl分加算, 1)
        Set CtrlLbl分加算(k).Lblドラムロール = Me("Lbl分加算" & k)
        Set CtrlLbl分減算(k).Lblドラムロール = Me("Lbl分減算" & k)
        Set CtrlLbl時加算(k).Lblドラムロール = Me("Lbl時加算" & k)
        Set CtrlLbl時減算(k).Lblドラムロール = Me("Lbl時減算" & k)
    Next k
    
    '時刻入力フォームの初期設定
    時分の初期値 = 時分の初期値_
    現在設定されている時分 = 時分の初期値_
    Lbl時.Caption = Hour(現在設定されている時分)
    Lbl分.Caption = Format(Minute(現在設定されている時分), "00")
    
    Call Update時のドラムロール(0)
    Call Update分のドラムロール(0)
    Call show時選択の文字盤
    Me.Show
    
    'フォームが非表示(Hide)されると本Functionの戻り値に時分が格納される
    Getフォームで選択した時間 = 現在設定されている時分
End Function
Public Sub set現在設定されている時分()
    現在設定されている時分 = TimeValue(Lbl時.Caption & ":" & Lbl分.Caption)
End Sub
'文字盤からフォームにマウスポインタが移動した時、ドラムロールを表示する
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If 文字盤上にマウスポインタがある = True Then
        Btn現在時刻.Caption = "現在時刻"
        
        Call toggleドラムロールの表示状態(True)
        Call Toggle時分の強調表示状態(False)
        Call 文字盤の文字を強調表示(-1)
            
        Lbl時.Caption = Hour(現在設定されている時分)
        Lbl分.Caption = Format(Minute(現在設定されている時分), "00")
        文字盤上にマウスポインタがある = False
    End If
End Sub
Public Function Get選択モードを取得() As e時分選択モード
    Get選択モードを取得 = 選択モード
End Function
'==============================
'        ボタン処理
'==============================

Private Sub Btn確定1_Click()
    Me.Hide
End Sub
Private Sub Btn確定2_Click()
    Me.Hide
End Sub
Private Sub Btnキャンセル_Click()
    現在設定されている時分 = 時分の初期値
    Me.Hide
End Sub
Private Sub Btn現在時刻_Click()
    現在設定されている時分 = Btn現在時刻.Caption
    Me.Hide
End Sub
'ボタンにマウスを乗せると現在の時刻を表示する
Private Sub Btn現在時刻_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Btn現在時刻.Caption = Format(Time, "hh:nn")
End Sub
'==============================
'        時分ラベル
'==============================

'時を選択できるようにする
Private Sub Lbl時_Click()
    Call show時選択の文字盤
End Sub
'分を選択できるようにする
Private Sub Lbl分_Click()
    Call show分選択の文字盤
End Sub
'今、時分のどちらを入力しているかを時分ラベルを強調表示してユーザーに伝える
Public Sub Toggle時分の強調表示状態(強調表示状態_ As Boolean)
    If 強調表示状態_ = False Then
        Lbl時.ForeColor = C_黒
        Lbl分.ForeColor = C_黒
        Exit Sub
    End If

    Select Case 選択モード
        Case mode時選択
            Lbl分.ForeColor = C_灰
        Case mode分選択
            Lbl時.ForeColor = C_灰
    End Select
End Sub
'==================================
'        ドラムロール部の処理
'==================================

'ドラムロール表示/非表示切替
Private Sub toggleドラムロールの表示状態(表示状態_ As Boolean)
    If Lbl分加算1.Visible = 表示状態_ Then Exit Sub

    Dim i As Long
    For i = 1 To 3
        Me("Lbl分加算" & i).Visible = 表示状態_
        Me("Lbl分減算" & i).Visible = 表示状態_
        Me("Lbl時加算" & i).Visible = 表示状態_
        Me("Lbl時減算" & i).Visible = 表示状態_
    Next i
End Sub
'時のドラムロールの数値を調整値の分だけずらす
Public Sub Update時のドラムロール(調整値_ As Long)
    With Lbl時
        .Caption = 時の計算(.Caption, 調整値_)
        Lbl時加算1.Caption = 時の計算(.Caption, 1)
        Lbl時減算1.Caption = 時の計算(.Caption, -1)
    End With
End Sub
'分のドラムロールの数値を調整値の分だけずらす
Public Sub Update分のドラムロール(調整値_ As Long)
    With Lbl分
        .Caption = 分の計算(.Caption, 調整値_)
        Lbl分加算1.Caption = 分の計算(.Caption, 1)
        Lbl分減算1.Caption = 分の計算(.Caption, -1)
    End With
End Sub
'時を計算する(計算結果は0時~23時で返す)
Private Function 時の計算(ByVal 時_ As String, ByVal 加算値_ As Long) As String
    時の計算 = Hour(DateAdd("h", 加算値_, 時_ & ":00"))
End Function
'分を計算する(計算結果は00分~59分で返す)
Private Function 分の計算(ByVal 分_ As String, ByVal 加算値_ As Long) As String
    分の計算 = Minute(DateAdd("n", 加算値_, "00:" & 分_))
    分の計算 = Format(分の計算, "00")
End Function
'==================================
'        文字盤部の処理
'==================================

'文字盤上でクリックすれば、時分が確定する
Private Sub Fra文字盤_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Call 時分確定処理
End Sub
'文字盤上でマウスポインタを動かすと、マウスポインタの位置に応じた時分を表示する
Private Sub Fra文字盤_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
                                                    ByVal x_マウスポインタ As Single, ByVal y_マウスポインタ As Single)
    
    If 選択モード = mode選択停止 Then
        Call Toggle時分の強調表示状態(False)
        Exit Sub
    End If
    
    '時分算出処理
    Dim 文字盤中心 As type文字盤中心座標
    Dim 二点間の角度 As Long
    Dim 二点間の距離 As Long
    
    文字盤中心 = get文字盤中心の座標
    二点間の角度 = get二点間の角度(文字盤中心.x, 文字盤中心.y, x_マウスポインタ, y_マウスポインタ)
    二点間の距離 = get二点間の距離(文字盤中心.x, 文字盤中心.y, x_マウスポインタ, y_マウスポインタ)
    
    Select Case 選択モード
        Case mode時選択
            Lbl時.Caption = get二点間の角度と距離から時を取得(二点間の角度, 二点間の距離)
        Case mode分選択
            Lbl分.Caption = get二点間の角度から分を取得(二点間の角度)
    End Select
    
    '表示関係の処理
    Dim 強調表示するLbl文字盤のID As Long
    文字盤上にマウスポインタがある = True
    強調表示するLbl文字盤のID = get強調表示するLbl文字盤のID(二点間の角度, 二点間の距離)
    Call 文字盤の文字を強調表示(強調表示するLbl文字盤のID)
    Call Toggle時分の強調表示状態(True)
    Call toggleドラムロールの表示状態(True)
End Sub
Private Function get強調表示するLbl文字盤のID(二点間の角度 As Long, 二点間の距離 As Long) As Long
    Dim 強調表示するLbl文字盤のID As Long
    強調表示するLbl文字盤のID = Round(二点間の角度 / 30, 0)

    If 強調表示するLbl文字盤のID = 0 Then
        強調表示するLbl文字盤のID = 12
    End If

    If 選択モード = mode時選択 And 二点間の距離 < 午前と午後との境目の距離 Then
        強調表示するLbl文字盤のID = 強調表示するLbl文字盤のID + 12
    End If
    
    get強調表示するLbl文字盤のID = 強調表示するLbl文字盤のID
End Function
Private Function get二点間の角度と距離から時を取得(二点間の角度_ As Long, 二点間の距離_ As Long) As String
    '角度を30で割ると時が算出できる
    'マウスポインタ位置が午前と午後との境目よりも外にある場合、午前を選択する
    DimAs Long
    If 二点間の距離_ > 午前と午後との境目の距離 Then= Round(二点間の角度_ / 30, 0)   '午前
    Else= Round(二点間の角度_ / 30, 0) + 12  '午後
    End If
    
    '表示形式を整える
    Select CaseCase 0= 12
        Case 12
            '00時と13時の間で表示が「12」になるのを補正
            If 二点間の距離_ < 午前と午後との境目の距離 Then= 0 '00時と13時の間
            End If
        Case 24= 0
    End Select
    
    get二点間の角度と距離から時を取得 =End Function
Private Function get二点間の角度から分を取得(二点間の角度_ As Long) As String
    '角度を6で割ると分が算出できる
    DimAs Long= Round(二点間の角度_ / 6, 0)
    
    '表示形式を整える
    If= 60 Then= 0
    End If
    
    get二点間の角度から分を取得 = Format(, "00")
End Function
'文字盤中心に対するマウスポインタ位置の相対的な角度を取得する(例:12時は0度、3時は90度、6時は180度、9時は270度)
Private Function get二点間の角度 _
                        (ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single, ByVal y2 As Single) As Long
    
    '角度θ = Atan2関数(x座標, y座標) ※原点(x1, y1)は文字盤中心
    'Degrees関数で[ラジアン単位]から[度単位]に変換
    Dim 角度 As Long
    With WorksheetFunction
        角度 = .Degrees(.Atan2((x2 - x1), (y2 - y1)))
    End With
    
    '12時を0度、6時を180度にするため補正を実施 ※Atan2関数は3時を0度、12時を-90度、6時を90度とするため補正が必要
    Select Case True
        Case x1 < x2 And y1 > y2
            角度 = (90 - Abs(角度))
        Case x1 < x2 And y1 < y2
            角度 = 角度 + 90
        Case x1 > x2 And y1 < y2
            角度 = 角度 + 90
        Case x1 > x2 And y1 > y2
            角度 = (450 - Abs(角度))
    End Select
    
    get二点間の角度 = 角度
End Function
Private Function get二点間の距離 _
                        (ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single, ByVal y2 As Single) As Long
    
    get二点間の距離 = Sqr((x2 - x1) ^ 2 + (y2 - y1) ^ 2)
End Function
Private Function get文字盤中心の座標() As type文字盤中心座標
    With Fra文字盤
        get文字盤中心の座標.x = .Width / 2
        get文字盤中心の座標.y = .Height / 2
    End With
End Function
'指定した文字盤の文字の色を変更して強調表示する
Public Sub 文字盤の文字を強調表示(強調するLbl文字盤のID_ As Long)
    '一度、全ての文字の文字色をリセットする
    Const 通常色 As Long = C_白
    Const 強調色 As Long = C_赤
    Dim i As Long
   
    For i = 1 To 24
        With Me.Controls("Lbl文字盤" & i)
            If .ForeColor = 強調色 Then
                .ForeColor = 通常色
            End If
        End With
    Next i
    
    '指定した文字盤の文字色を変更(ラベルIDが-1であれば強調表示処理はしない)
    If 強調するLbl文字盤のID_ = -1 Then Exit Sub
    Me.Controls("Lbl文字盤" & 強調するLbl文字盤のID_).ForeColor = 強調色
End Sub
Public Sub 時分確定処理()
    Select Case 選択モード
        Case mode選択停止
            Exit Sub
        Case mode時選択
            Call Update時のドラムロール(0)
            Call show分選択の文字盤
        Case mode分選択
            Call Update分のドラムロール(0)
            Call show選択停止の文字盤
    End Select
    
    Call set現在設定されている時分
    Txt時.Value = ""
    Txt分.Value = ""
    Txt時.SetFocus
End Sub
'時計の文字盤を0~23時の時表示にする
Private Sub show時選択の文字盤()
    Dim x As Long
    For x = LBound(CtrlLbl文字盤, 1) To UBound(CtrlLbl文字盤, 1)
        With Me.Controls("Lbl文字盤" & x)
            Select Case x
                Case 1 To 12    '外側のラベル(0時~12時)
                    .Caption = x
                Case 13 To 24   '内側のラベル(13時~0時)
                    .Visible = True
            End Select
        End With
    Next x
    
    選択モード = mode時選択
    Btn確定2.Visible = False
End Sub
'時計の文字盤を5分刻みの分表示にする
Private Sub show分選択の文字盤()
    Dim x As Long
    For x = LBound(CtrlLbl文字盤, 1) To UBound(CtrlLbl文字盤, 1)
        With Me.Controls("Lbl文字盤" & x)
            Select Case x
                Case 1 To 11
                    .Caption = Format(x * 5, "00")  '5分刻みの表示
                Case 12
                    .Caption = "00"
                Case 13 To 24   '内側のラベル(13時~0時)
                    .Visible = False
                End Select
        End With
    Next x
    
    選択モード = mode分選択
    Btn確定2.Visible = False
End Sub
'文字盤の文字を消す
Private Sub show選択停止の文字盤()
    Dim x As Long
    For x = LBound(CtrlLbl文字盤, 1) To UBound(CtrlLbl文字盤, 1)
        With Me.Controls("Lbl文字盤" & x)
            Select Case x
                Case 1 To 12    '外側のラベル(0時~12時)
                    .Caption = ""
                Case 13 To 24   '内側のラベル(13時~0時)
                    .Visible = False
            End Select
        End With
    Next x
    
    選択モード = mode選択停止
    Btn確定2.Visible = True
End Sub
'==============================
'       時分手入力部の処理
'==============================

Private Sub Txt時_Change()
    With Txt時
        If .Value = "" Then Exit Sub
        
        If is文字が数値か(Right(.Value, 1)) = True Then
            .Value = 右からn文字削除(.Value, 1)
            Exit Sub
        End If
        
        If .Value >= 24 Then
            .Value = 右からn文字削除(.Value, 1)
            Exit Sub
        End If
        
        Lbl時.Caption = .Value
        Call update時のドラムロールの数値を更新(0)
        Call set現在設定されている時分
        
        If Len(.Value) = 2 Then
            Txt分.SetFocus
        End If
    End With
End Sub
Private Sub Txt分_Change()
    With Txt分
        If .Value = "" Then Exit Sub
        
        If is文字が数値か(Right(.Value, 1)) = True Then
            .Value = 右からn文字削除(.Value, 1)
        End If
        
        If .Value >= 60 Then
            .Value = 右からn文字削除(.Value, 1)
        End If
        
        Lbl分.Caption = .Value
        Call update分のドラムロールの数値を更新(0)
        Call set現在設定されている時分
    End With
End Sub
Private Sub Txt分_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    'KeyCode13 : Enterキー
    If KeyCode = 13 Then Me.Hide
End Sub

クラスモジュール(Cls時刻入力)

Private WithEvents TgtLbl文字盤 As MSForms.Label
Private WithEvents TgtLblドラムロール As MSForms.Label

Property Set Lbl文字盤(ByVal new_ctrl As MSForms.Label)
    Set TgtLbl文字盤 = new_ctrl
End Property
Property Set Lblドラムロール(ByVal new_ctrl As MSForms.Label)
    Set TgtLblドラムロール = new_ctrl
End Property
'時分加減算ラベルをクリックしたとき、時分を加減算する処理
Private Sub TgtLblドラムロール_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    Dim tgtLblName As String: tgtLblName = TgtLblドラムロール.Name
    Dim 調整値 As Long
    Select Case Right(tgtLblName, 1)
        Case 1
            調整値 = 1
        Case 2
            調整値 = 5
        Case 3
            調整値 = 10
    End Select
    
    If InStr(tgtLblName, "減算") <> 0 Then
        調整値 = -調整値
    End If
    
    With Frm時刻入力
        If InStr(tgtLblName, "Lbl時") <> 0 Then
            Call .Update時のドラムロール(調整値)
        Else
            Call .Update分のドラムロール(調整値)
        End If
    
        .Txt時.Value = ""
        .Txt分.Value = ""
        .Txt時.SetFocus
        Call .set現在設定されている時分
    End With
End Sub
'文字盤の文字をクリックしたとき、クリックした時分で時分を確定する
Private Sub TgtLbl文字盤_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    With Frm時刻入力
        Select Case .Get選択モードを取得
            Case mode選択停止
                Exit Sub
            Case mode時選択
                .Lbl時.Caption = TgtLbl文字盤.Caption
            Case mode分選択
                .Lbl分.Caption = TgtLbl文字盤.Caption
        End Select
        
        Call .時分確定処理
    End With
End Sub
'文字盤のラベル上にマウスポインタを置くと、置いたラベルの時分が表示される
Private Sub TgtLbl文字盤_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    With Frm時刻入力
        If .Get選択モードを取得 = mode選択停止 Then Exit Sub
        
        Dim tgtLblCaption As String
        tgtLblCaption = TgtLbl文字盤.Caption
        
        Select Case .Get選択モードを取得
            Case mode時選択
                If tgtLblCaption = "00" Then
                    .Lbl時.Caption = "0"
                Else
                    .Lbl時.Caption = tgtLblCaption
                End If
            Case mode分選択
                .Lbl分.Caption = tgtLblCaption
        End Select
   
        Const Lbl文字盤nameのIDを除く文字数 As Long = 6
        Dim 強調表示するLbl文字盤のID As Long
        強調表示するLbl文字盤のID = 左からn文字削除(TgtLbl文字盤.Name, Lbl文字盤nameのIDを除く文字数)
        Call .文字盤の文字を強調表示(強調表示するLbl文字盤のID)
    End With
End Sub

調整

以下のケースの場合、フォームモジュール内のPrivate定数「午前と午後との境目の距離」の値を弄って調整してください。

  • 時を選択時、午前を選択したいのに午後が選択される
  • 時を選択時、午後を選択したいのに午前が選択される

例)15と3の間にマウスポインタがあるのに15が表示される

余談

今回は時刻入力フォームの紹介でしたが、とても便利な日付入力フォームを自作した方がいます。
日付入力が格段に効率的になるので、導入することをお勧めします。
ateitexe.com

f:id:atsushi_ota:20201003234316p:plain
図 リンク先の説明をもとに作成した日付入力フォーム

列挙体を使用して自作の組み込み定数を作る

組み込み定数とは、VBAが初めから用意している定数のことを指します。
一例を挙げると、「vbOK」「vbRed」「xlUp」「xlCenter」等が存在します。

この組み込み定数は非常に便利なもので、例えばメッセージボックスだと、組み込み定数が使えるおかげでメッセージボックスに表示するボタン・アイコンを簡単に設定が可能となっています。
f:id:atsushi_ota:20200823233757p:plain

今回は列挙体を使用して自作の組み込み定数を作成します。

作成手順

まず組み込み定数とする列挙体を作成します。
接頭語はあった方がコーディング時に便利なので、お好みで設定してください。
今回はExtend(【意味】拡張する)の略語であるxtndにしてみました。

Private Enum e外貨の種類
    xtnd米ドル
    xtndユーロ
    xtnd人民元
    xtnd露ルーブル
End Enum

次に Functionプロシージャの引数の型を、先ほど作成した列挙体に設定します。

Private Function 外貨為替レート計算(日本円_ As Long, 外貨_ As e外貨の種類) As Currency
    Dim 両替結果 As Single
    
    '両替結果の計算は日本円×各通貨の為替レート
    Select Case 外貨_
        Case xtnd米ドル
            両替結果 = 日本円_ * 0.0095
        Case xtndユーロ
            両替結果 = 日本円_ * 0.008
        Case xtnd人民元
            両替結果 = 日本円_ * 0.065
        Case xtnd露ルーブル
            両替結果 = 日本円_ * 0.71
    End Select
    
    外貨為替レート計算 = 両替結果
End Function

以上で自作の組み込み定数の設定は完了です。
メリットとしては、インテリセンスが使用できるのでタイプミスによるバグが減る&コーディングが楽なことです。
自作組み込み定数を設定した Functionプロシージャを多用する時、大いに役立つことでしょう。

Public Sub 日本円を為替計算してみる()
    Dim 日本円 As Long
    日本円 = InputBox("為替計算する日本円の金額を入力してください。")
    MsgBox "米ドルの場合:" & 外貨為替レート計算(日本円, xtnd米ドル) & "米ドルです。" & vbLf & _
                "ユーロの場合:" & 外貨為替レート計算(日本円, xtndユーロ) & "ユーロです。" & vbLf & _
                "人民元の場合:" & 外貨為替レート計算(日本円, xtnd人民元) & "人民元です。" & vbLf & _
                "露ルーブルの場合:" & 外貨為替レート計算(日本円, xtnd露ルーブル) & "露ルーブルです。"
End Sub
f:id:atsushi_ota:20200823235903p:plain
図 自作組み込み定数活用例
注意事項

下記のように自作組み込み関数に使用する列挙体の要素名が、他の列挙体の要素名にも使用されている時、エラーが発生します。
エラーを回避するためには要素名を変える以外にはありません。

Private Enum e外貨の種類
    xtnd米ドル
    xtndユーロ
    xtnd人民元
    xtnd露ルーブル
End Enum

Private Enum e日本円に両替する外貨の種類
    xtnd米ドル
    xtndユーロ
    xtnd人民元
    xtnd露ルーブル
End Enum
f:id:atsushi_ota:20200824001536p:plain
図 列挙体の要素名重複によるエラー

配列を疑似定数化して活用する

VBAでは配列を定数として定義することはできません。
しかし、以下の方法により疑似定数化することができます。

Public Function array職業() As Variant
    Dim arrTmp(1 To 4) As Variant
    arrTmp(1) = "自営業"
    arrTmp(2) = "会社員"
    arrTmp(3) = "公務員"
    arrTmp(4) = "無職"
    array職業 = arrTmp
End Function

これにより、一番メリットを享受できるのは、コンボボックスやリストボックスの初期値を設定する時ではないでしょうか。
ある程度の規模のシステムになってくると、複数のユーザーフォームを使用することになります。
下の図のように、各々のフォームで同じ初期値を設定するコンボボックス等が発生することがあります。
その際に今回紹介する疑似定数が活躍してくれます。

f:id:atsushi_ota:20200812225538p:plain
図 登録フォーム
f:id:atsushi_ota:20200812224940p:plain
図 検索フォーム

また、メンテナンス性も向上します。
具体例としては、コンボボックス等の初期値の変更があった場合にコードを書き換える場所が最小限で済みます。

今回のアイデアは下のブログ記事を応用したものです。
定数として定義できないものでも、Functionを使えば疑似定数化できますね。
www.limecode.jp

以下、フォームのコンボボックスの初期値を設定するサンプルプログラムです。

標準モジュール
Public Function array職業() As Variant
    Dim arrTmp(1 To 4) As Variant
    arrTmp(1) = "自営業"
    arrTmp(2) = "会社員"
    arrTmp(3) = "公務員"
    arrTmp(4) = "無職"
    array職業 = arrTmp
End Function
Public Function array住居形態() As Variant
    Dim arrTmp(1 To 2) As Variant
    arrTmp(1) = "集合住宅"
    arrTmp(2) = "一軒家"
    array住居形態 = arrTmp
End Function
Public Function array自動車免許証の色() As Variant
    Dim arrTmp(1 To 3) As Variant
    arrTmp(1) = "ゴールド"
    arrTmp(2) = "青"
    arrTmp(3) = "緑"
    array自動車免許証の色 = arrTmp
End Function
データ入力フォームモジュール
Private Sub UserForm_Initialize()
    ComboBox1.List = array職業
    ComboBox2.List = array住居形態
    ComboBox3.List = array自動車免許証の色
End Sub
検索フォームモジュール
Private Sub UserForm_Initialize()
    ComboBox1.List = array職業
    ComboBox2.List = array住居形態
    ComboBox3.List = array自動車免許証の色
End Sub

ユーザーに業務システムを上書き保存させない仕組み

私はExcelで作成した業務システムファイルを、ユーザーに上書き保存させたくありません。
理由は下記の例のように、マクロの実行が不可能となる操作をユーザーがする場合があるからです。
・マクロの動作に必要なシートを、誤ってユーザーが削除した
・ワークシート上に配置したコマンドボタンを削除した
・列を追加したのでマクロで参照するセル位置がずれた

その状態で上書き保存した場合、ユーザーは業務システムを利用できなくなります。
そこで上書き保存できない仕組みを作ることで、何かトラブルがあってもシステムファイルを開きなおせば再び業務システムを利用できる環境を構築することができます。
もちろん、ユーザーの意図しない操作に対して耐えることができるプログラムを組むのが大切なのですが...

本マクロは以下の仕様となっています。
・上書き保存、名前を付けて保存を実行させない。
 ただし、Cell(1,1).Value が「保存許可」の場合、上書き保存ができる。
 ※プログラム保守時の利便性向上目的

・ブックを閉じるとき、保存を行うか確認するメッセージを出さずにブックを閉じる。
 ただし、Cell(1,1).Value が「保存許可」の場合、上書き保存するか確認する。
 ※プログラム保守時の利便性向上目的

Option Explicit

Private Function SetCell_ファイル保存フラグ() As Range
    'ファイル保存フラグとして使用するセルを返す
    Set SetCell_ファイル保存フラグ = Cells(1, 1)
End Function
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    ' 上書き保存の許可フラグが立っていなければ保存処理を中止する。
    ' Cellファイル保存フラグ.Valueが「保存許可」または「保存許可(終了処理)」の場合、フラグは立っている。
    ' 「保存許可(終了処理)」とは、ファイルを保存して閉じる場合に使用されるフラグで、
    'この場合はフラグを降ろしてから保存処理を実行する。
    Dim Cellファイル保存フラグ As Range
    Set Cellファイル保存フラグ = SetCell_ファイル保存フラグ
    
    With Cellファイル保存フラグ
        If .Value <> "保存許可" And .Value <> "保存許可(終了処理)" Then
            Cancel = True
            Exit Sub
        End If
        
        If .Value = "保存許可(終了処理)" Then
            .Value = ""
        End If
    End With
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    '保存許可フラグが立っていない場合は、保存せずに閉じる。
    'フラグが立っている状態でファイルを閉じる場合、保存するか選択できる。
    Dim Cellファイル保存フラグ As Range
    Set Cellファイル保存フラグ = SetCell_ファイル保存フラグ

    If Cellファイル保存フラグ.Value <> "保存許可" Then
        ThisWorkbook.Saved = True
        Exit Sub
    End If
    
    Select Case MsgBox("ファイルを閉じますが、保存しますか?", vbInformation + vbYesNoCancel)
        Case vbYes
            Cellファイル保存フラグ.Value = "保存許可(終了処理)"
            ThisWorkbook.Save
        Case vbNo
            ThisWorkbook.Saved = True
        Case vbCancel
            Cancel = True
    End Select
End Sub
Private Sub Workbook_Open()
    'ファイルを開いたときは、保存許可フラグを降ろしておく
    Dim Cellファイル保存フラグ As Range
    Set Cellファイル保存フラグ = SetCell_ファイル保存フラグ
    
    Cellファイル保存フラグ.Value = ""
End Sub
Public Sub Saveファイルを保存()
    '上書き保存を禁止しているファイルを強制的に保存する
    Dim Cellファイル保存フラグ As Range
    Set Cellファイル保存フラグ = SetCell_ファイル保存フラグ

    With Cellファイル保存フラグ
        .Value = "保存許可"
        ThisWorkbook.Save   'Workbooks_BeforeSaveの処理が実行される
        .Value = ""
    End With
End Sub

エラーメッセージ付きis関数の活用

ある対象が条件に当てはまるかを確認するis関数エラーメッセージを表示する機能を合わせた関数を作ると便利ですよ。という記事です。
例えば「文字列が数値のみか」を確認する場合は、以下のようなコードとなります。

Public Function Is文字列が数値か(ByVal 確認する文字列_ As String, _
 Optional ByVal エラーメッセージ_ As String = "数値のみで入力してください。") As Boolean
    '文字列が数値であればTrue

    If IsNumeric(確認する文字列_) = True Then
     Is文字列が数値か = True
    Else
        Is文字列が数値か = False
        MsgBox_入力間違い (エラーメッセージ_)
    End If
End Function
使用例

先ほどの自作関数の使用例は下記のとおりです。
年齢のインプットボックスで「あ」を入力すると、エラーメッセージが表示されて処理が終了します。
この時のエラーメッセージは、自作関数の引数エラーメッセージ_ の既定値である「数値のみで入力してください。」と表示されます。

暗証番号のインプットボックスで「あ」を入力すると、先ほどと同様にエラーメッセージが表示されて処理が終了しますが、自作関数呼び出し時にエラーメッセージを設定していますので、エラーメッセージは「暗証番号は数値のみで入力してください。」と表示されます。

Public Sub Test1()
    Dim 年齢 As String  '説明のためLong型ではなくString型にしています。"
    年齢 = InputBox("年齢を入力してください。")
    If Is文字列が数値か(年齢) = False Then Exit Sub
    
    Dim 暗証番号 As String '説明のためLong型ではなくString型にしています。"
    暗証番号 = InputBox("暗証番号を入力してください。")
    If Is文字列が数値か(暗証番号, "暗証番号は数値のみで入力してください。") = False Then Exit Sub
End Sub
メリット

このエラーメッセージ付きis関数のメリットは以下の3つです。

  1. メインの処理コードがシンプルになり、コードの可読性・保守性の向上
  2. エラーメッセージ付きis関数を複数種類作成し、各確認項目で活用することで開発性が向上
  3. 当該関数群をモジュール化することで、新規プログラム開発時にエラーメッセージ付きis関数を容易に移植でき、開発期間を短くすることが可能

業務システムにおいて、ユーザーが入力した値が正しいかどうか確認する機能は必須です。

確認する項目が多いほど、エラーメッセージ付きis関数の効果を発揮しますので、是非使用してみてください。

(参考)「郵便番号」の値が正しいか確認するコード

【メイン処理】

Public Function is郵便番号が正しいか(ByVal 郵便番号_ As String) As Boolean
 '郵便番号が正しければTrue

 is郵便番号が正しいか = False
  
 If is文字列が半角文字のみか(郵便番号_, "郵便番号は半角で入力してください。") = False Then Exit Function
 If Is文字列が指定文字数か(郵便番号_, 8, "郵便番号は8文字で入力してください。") = False Then Exit Function
    
 If Is文字列が数値か(Left(郵便番号_, 3), "郵便番号の上3桁は数字で入力してください。") = False Then Exit Function
 If is文字列が指定文字か(Mid(郵便番号_, 4, 1), "-", "郵便番号の4文字目は「-」を入力してください。") = False Then Exit Function
 If Is文字列が数値か(Right(郵便番号_, 4), "郵便番号の下4桁は数字で入力してください。") = False Then Exit Function
    
 is郵便番号が正しいか = True
End Function

【メッセージ付きis関数群】

Public Function Is文字列が数値か(ByVal 確認する文字列_ As String, _
  Optional ByVal エラーメッセージ_ As String = "数値のみで入力してください。") As Boolean
    '文字列が数値であればTrue

    If IsNumeric(確認する文字列_) = True Then
         Is文字列が数値か = True
    Else
        Is文字列が数値か = False
        MsgBox_入力間違い (エラーメッセージ_)
    End If
End Function
Public Function Is文字列が指定文字数か(ByVal 確認する文字列_ As String, _
  ByVal 指定文字数_ As Long, _
  Optional ByVal エラーメッセージ_ As String = "入力した文字列に過不足があります。") As Boolean
    '文字列の文字数が指定した文字数であればTrue
    
    If Len(確認する文字列_) = 指定文字数_ Then
        Is文字列が指定文字数か = True
    Else
        Is文字列が指定文字数か = False
        MsgBox_入力間違い (エラーメッセージ_)
    End If
End Function
Public Function is文字列が半角文字のみか(ByVal 確認する文字列_ As String, _
  Optional ByVal エラーメッセージ_ As String = "半角のみで入力してください。")
    '文字列が全て半角文字であればTrue

    If StrConv(確認する文字列_, vbNarrow) = 確認する文字列_ Then
        is文字列が半角文字のみか = True
    Else
        Call MsgBox_入力間違い(エラーメッセージ_)
        is文字列が半角文字のみか = False
    End If
End Function
Public Function is文字列が指定文字か(ByVal 確認する文字列_ As String, ByVal 指定文字_ As String, _
  Optional ByVal エラーメッセージ_ As String = "入力した文字列は使用できません。")
    '文字列が指定した文字列であればTrue
    '[指定文字列]は単数もしくは複数が設定可能。複数の場合は[,]で区切ること。 例:[a,b,c]
    
    Dim arr指定文字 As Variant
    arr指定文字 = Split(指定文字_, ",")
    
    Dim X As Long
    For X = LBound(arr指定文字) To UBound(arr指定文字)
        If 確認する文字列_ = arr指定文字(X) Then
            is文字列が指定文字か = True
            Exit Function
        End If
    Next X
    
    MsgBox_入力間違い エラーメッセージ_
    is文字列が指定文字か = False
End Function

従業員に配布した業務システムを自動でアップデートさせる

業務システムの運用開始は、同時にシステム改修の開始を意味します。
それは運用開始前に発見できなかったバグや、追加機能の要望、管理するデータの種類が増える等、原因は様々です。

そこで従業員に配布した業務システムを自動でアップデートさせる仕組みを紹介します。

※この記事で説明しているシステムの構造については以下のの記事参照 
 atsushi-ota.hateblo.jp

自動アップデートの仕組み

 f:id:atsushi_ota:20200610223017p:plain

仕組みを一言で言うと、システム起動時にマスターファイルとローカルファイルの名前を比較し、差があればシステムを更新します。
※マスターファイル:ファイルサーバに保管されたシステムファイル
 ローカルファイル:マスターファイルを各従業員のPCにコピーしたシステムファイル

システムファイル名は「〇〇管理システムv1.00.xlsm」のようにバージョン番号を振ります。
システム改修の際は「〇〇管理システムv1.01.xlsm」にしてファイルサーバ上に保存し、古いバージョンのファイルを削除します。

そして従業員が自分のPCに保存した「〇〇管理システムv1.00.xlsm」を起動すると、マスターファイル名と差が生じるのでアップデートを開始します。

アップデートの詳細な流れは以下のとおりです。

  1. ローカルファイルを開く
  2. ローカルファイル名とマスターファイル名を比較
  3. ファイル名に差があれば、マスターファイルをローカルファイルが保存されている場所にコピー
  4. 古いローカルファイルを削除
  5. 新しいローカルファイルを開く
VBAコード

ThisWorkBookモジュール

Option Explicit

Private Sub Workbook_Open()
    Call Main起動時の処理
End Sub

標準モジュール

Option Explicit

Private Const C_マスターファイル保管フォルダのパス As String = _
    "C:\Users\Atsushi\"
Private Const C_システム名 As String = "〇〇管理システム"
Public Sub Main起動時の処理()
 Dim マスターファイル名 As String

    '起動時の処理
    マスターファイル名 = getマスターファイル名を取得
    
    If isバージョンはマスタと同じか(マスターファイル名) = False Then
        Call upgradeシステムをバージョンアップ(マスターファイル名)
    End If    
End Sub
Private Function getマスターファイル名を取得() As String
    '指定したフォルダ内からマスターファイル名を取得する

    Dim bufファイル名 As String
    bufファイル名 = Dir(C_マスターファイル保管フォルダのパス & "〇〇管理システムv*.xlsm")
    
    Do While bufファイル名 <> ""
        getマスターファイル名を取得 = bufファイル名
        Exit Function
    Loop
    
    MsgBox C_システム名 & "のマスターファイルが存在しません。" & vbLf & _
                        C_システム名 & "を強制終了します。"
    ThisWorkbook.Close (False)
    End
End Function
Private Function isバージョンはマスタと同じか(ByVal マスターファイル名_ As String) As Boolean
    'バージョンがマスターファイルと同じであればTrue

    If ThisWorkbook.Name = マスターファイル名_ Then
        isバージョンはマスタと同じか = True
    Else
        isバージョンはマスタと同じか = False
    End If
End Function
Private Sub upgradeシステムをバージョンアップ(ByVal マスターファイル名_ As String)
    'マスターファイルをコピーして、今開いているブックは削除する

    Dim マスターファイルのフルパス As String
    Dim コピー先ファイルのフルパス As String
    
    マスターファイルのフルパス = C_マスターファイル保管フォルダのパス & マスターファイル名_
    コピー先ファイルのフルパス = ThisWorkbook.Path & "\" & マスターファイル名_
    
    FileCopy マスターファイルのフルパス, コピー先ファイルのフルパス
    MsgBox C_システム名 & "をバージョンアップしました。" & vbLf & _
                        "最新の" & C_システム名 & "を開きます"
    
    Workbooks.Open コピー先ファイルのフルパス
    Call deleteこのブックファイルを削除
End Sub
Private Sub deleteこのブックファイルを削除()
    '自分自身を削除する
    With ThisWorkbook
        .Save
        .ChangeFileAccess Mode:=xlReadOnly
        Kill .FullName
        .Close (False)
    End With
End Sub
システムのバージョン番号について

 私は以下のルールを設けてバージョンアップ後のバージョン番号を決めています。

  • システム改修によりAccessのテーブル構造を変更した場合はメジャーアップデート 例:「1.00」→「2.00」
  • テーブル構造を変更していない場合はマイナーアップデート 例:「1.00」→「1.01」

ExcelVBA+Access+ファイルサーバで作るシステム

この記事の執筆時点で私は計4種の業務システムを開発しましたが、全てExcel+Access+ファイルサーバを利用したシステム構成となっています。

システム構成

f:id:atsushi_ota:20200610204822p:plain


システムの構成はこの通りです。

  • Accessは業務システムのデータが蓄積されるデータベース
  • Excelはデータベースへのデータ入出力を行う業務システムの表示・操作部

両ファイルは全従業員が接続できる共有フォルダに格納し、さらに共有フォルダに格納したExcelファイルのコピーを各従業員のPCに保存します。

このシステムはExcelAccessの良いところを取り入れています。

Excelはグラフや計算機能が優れているものの、ファイルサイズが大きくなると動作が不安定になります。

Accessはその逆で大量のデータの扱いは得意ですが、複雑な計算や画面処理の作成に苦労することがあります。

また、多くの場合はAccessがPCにインストールされておらず、Accessのライセンスを利用者の人数分別途購入する必要があります。

そこでデータベースとしての役割をAccessに移譲し、その他の役割をExcelが担う分業制が考えられます。

この場合、Accessのライセンス購入はDBを設計する人のみで済むので経済的です。

システムの操作性

Excelをシステムのインターフェースとする最大の利点は、システム利用者が新たにAccessの操作について学ぶ必要が無いことです。

変化することは多くの人にとってストレスでしかないので、多くの従業員が使い慣れているであろうExcelをインターフェースにすることで変化量を小さくすることができ、余計なトラブルを抑えることができます。

また、システムからExcelに出力されたデータを利用者が二次利用しやすいというメリットもあります。

データベースへの同時接続と更新

ファイルサーバ上に保存されているExcelファイルは、誰かが先に開いていると保存することができませんが、Accessではそれが可能です。

システムの更新

ファイルサーバに保管しているExcelファイル名を変更することで、各従業員のPCに保存されたExcelファイルが自動更新できるように設計します。

具体的な方法については下記の記事にて説明しています。
 
atsushi-ota.hateblo.jp

メールによるシステム配布・更新だと、利用者の手間が増えるだけでなく、更新漏れによる重篤なエラーを引き起こす可能性がありますのでオススメしません。
 

Accessをデータベースとする際の注意点

複数人で一つのAccessファイルを使用すると、そのAccessファイルは壊れやすいという話をネット上で多数確認できます。

実際壊れやすいのかもしれませんが、私の使用環境では一度も壊れたことはありません。
参考として私の使用環境について記載しておきます。

  • Excel2013
  • Access2003(ファイル形式は.mdb
  • Wifi接続
  • 20名ほどが使用しているシステム
  • ピーク時のデータベース接続件数/分は「計測中」
  • Accessファイルにはテーブルのみ作成。クエリ等はない
  • リレーションシップは使用している
  • 最大フィールド数は「確認中」
  • Accessファイルサイズは「確認中」
  • Accessの設定で「閉じるときに最適化する」を有効化
  • Microsoft.ACE.OLEDB.12.0を使用
  • データの登録、更新、削除はトランザクション処理
  • Accessファイルへの接続時間は最短となるように設計
  1. データ読込準備(SQL文を作る)
  2. データベース接続
  3. データ読込
  4. データを配列に格納
  5. データベース切断
  6. データをシートやフォームに出力