【知らなくても使える】シート毎の更新された日時を各シートに書き込むマクロツール（Excel VBA）

Option Explicit

'-----（設定値）------------------------
Private Const DATA_ROW = 7                      '１．設定シート内の設定表が開始する行番号
Private Const DATA_COL_NUM = 3                  '２．設定シート内の設定表が開始する列番号
Private Const DATA_EACH_COL_NUM = 5             '３．設定シート内の設定表（個別設定）が開始する列番号
Private Const SETTING_SHEET_NM = "setting"      '４．設定シートのシート名称
'---------------------------------------

Dim SettingSheet As Worksheet                   '設定シート

Dim BeforeValue As String                       'セル内に入っている変更前の値
Dim TRow As Long, TCol As Long                  '選択されたセルの行番号と列番号
    
Dim TgtCellPoint As String                      '一括設定のセル位置
Dim TgtEachlist() As String                     '個別設定情報が格納されたリスト（0:シート名、1:セル位置）
Dim TgtUpdateList() As String                   '変更したシート等の情報が格納されたリスト（0:シート名、1:セル位置、2:更新日時）
Dim CntChgSh As Integer                         '変更したシートの数

'===================================
'エクセル起動時に実行する処理
'===================================
Private Sub Workbook_Open()
    
    '初期処理をする
    Call Initialize
    
    '設定シートの情報を取得する
    Call GetSetting
    
End Sub
 
'===================================
'エクセル内のセル等を選択した時の処理
'===================================
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
 
    On Error Resume Next
    
    '変更前のセル内容を一時保管します。
    BeforeValue = ActiveSheet.Cells(ActiveCell.Row, ActiveCell.Column).Value
    
End Sub

'===================================
'エクセル内の値を変更した時の処理
'===================================
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    Application.EnableEvents = False
    
    '配列が空の場合はTgtUpdateListリストを作成する
    If IsEmptyArray(TgtUpdateList) Then
        Call Initialize
    End If
    
    '設定情報を取得する
    Call GetSetting
    
    Dim i As Long
    Dim exitFlg As Boolean: exitFlg = False
    
    'シート「setting」以外のシートで変更があった場合のみ処理する
    If ActiveSheet.Name <> SETTING_SHEET_NM Then
 
        TCol = Target.Column
        TRow = Target.Row
        
        '値が変更されていた場合のみ処理する
        If BeforeValue <> ActiveSheet.Cells(TRow, TCol).Value Then

            '既に変更されたデータが格納されていないかチェックする
            For i = 0 To UBound(TgtUpdateList, 1)

                If TgtUpdateList(i, 0) = ActiveSheet.Name Then
                    exitFlg = True
                    Exit For
                End If
            Next

            If exitFlg = False Then

                ReDim Preserve TgtUpdateList(2, CntChgSh)

                '個別設定があれば、そのセル位置を取得する
                For i = 0 To UBound(TgtEachlist, 1)

                    If ActiveSheet.Name = TgtEachlist(i, 0) Then
                        TgtUpdateList(1, CntChgSh) = TgtEachlist(i, 1)                 'セル位置
                        Exit For
                    End If
                Next

                '個別設定がなければ、一括設定のセル位置を取得する
                If TgtUpdateList(1, CntChgSh) = "" Then
                    TgtUpdateList(1, CntChgSh) = TgtCellPoint                          'セル位置
                End If

                TgtUpdateList(0, CntChgSh) = ActiveSheet.Name                          'シート名
                TgtUpdateList(2, CntChgSh) = Format(Now(), "YYYY/MM/DD HH:MM:SS")      '更新時間

                CntChgSh = CntChgSh + 1

            End If
        End If
    End If
 
    Application.EnableEvents = True
 
End Sub

'===================================
'エクセル保存した際の処理
'===================================
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    
    Dim i As Long
    
    '配列が空かどうかチェックする（空の場合はTrueを返す）
    If IsEmptyArray(TgtUpdateList) Then Exit Sub
    
    '変更情報があれば指定されたセルに更新情報を記載する
    If TgtUpdateList(2, 0) <> "" Then
        For i = 0 To UBound(TgtUpdateList, 2)

            ActiveWorkbook.Sheets(TgtUpdateList(0, i)).Range(TgtUpdateList(1, i)).Value = Format(Now(), "YYYY/MM/DD HH:MM:SS")
        Next
    End If

    CntChgSh = 0
    ReDim TgtUpdateList(2, CntChgSh)

End Sub

'-------------------------
'初期処理をする
'-------------------------
Private Sub Initialize()

    Set SettingSheet = ActiveWorkbook.Sheets(SETTING_SHEET_NM)
    ReDim TgtUpdateList(2, 0)
    
End Sub

'-------------------------
'設定シートの情報を取得する
'-------------------------
Private Sub GetSetting()

    Dim lastRow As Integer
    Dim i As Long
    
    '一括設定で指定された更新日時を記載するセル位置を取得する
    TgtCellPoint = SettingSheet.Cells(DATA_ROW, DATA_COL_NUM).Value
    
    '個別設定データの最終行を取得する
    lastRow = SettingSheet.Cells(Rows.Count, DATA_EACH_COL_NUM).End(xlUp).Row
    
    If lastRow < DATA_ROW Then
        Exit Sub
    End If
    
    ReDim TgtEachlist(lastRow - DATA_ROW, 2)
    
    '個別設定で指定されたシート名と記載セル位置を取得する
    For i = DATA_ROW To lastRow
        
        'シート名に値があり、記載セル位置に値がない場合は、該当行の文字色を赤色にする
        If SettingSheet.Cells(i, DATA_EACH_COL_NUM).Value <> "" And SettingSheet.Cells(i, DATA_EACH_COL_NUM + 1).Value <> "" Then
            
            TgtEachlist(i - DATA_ROW, 0) = SettingSheet.Cells(i, DATA_EACH_COL_NUM).Value
            TgtEachlist(i - DATA_ROW, 1) = SettingSheet.Cells(i, DATA_EACH_COL_NUM + 1).Value
            SettingSheet.Cells(i, DATA_EACH_COL_NUM).Font.ColorIndex = 1                        '個別設定表の項目「シート名」の文字色を黒にする
            SettingSheet.Cells(i, DATA_EACH_COL_NUM + 1).Font.ColorIndex = 1                    '個別設定表の項目「記載位置」の文字色を黒にする
        Else
            SettingSheet.Cells(i, DATA_EACH_COL_NUM).Font.ColorIndex = 3                        '個別設定表の項目「シート名」の文字色を赤にする
            SettingSheet.Cells(i, DATA_EACH_COL_NUM + 1).Font.ColorIndex = 3                    '個別設定表の項目「記載位置」の文字色を赤にする
            
        End If
    Next

End Sub

'-------------------------
'配列が空かチェックする
' 空の場合はTrueを返す
'-------------------------
Private Function IsEmptyArray(tmpArry As Variant) As Boolean
    
On Error GoTo err
    
    'UBound関数を使用してエラーが発生するかで確認する
    If (0 < UBound(tmpArry, 1)) Then
        IsEmptyArray = False
    Else
        IsEmptyArray = True
    End If
    
    Exit Function

err:
    'エラーが発生した場合（空の場合）はTrueを返す
    IsEmptyArray = True
    
End Function