ToDoファイル作成マクロ

ToDoファイルを作成するマクロを作ってみた。

セル/フォントの装飾、入力規則、条件付き書式、テーブル化など、基本的なマクロがモリモリなため、初心者ならこれを参考に一つ一つ理解しながらファイル作成を行うと、かなりスキルアップすると感じる。

個人用マクロなどにコピーし、実行すると自身のデスクトップに作成される

当ToDoファイルの説明や命令の説明は、後日追記する。
※Stackシートへの退避は未実装

Option Explicit
Public Const C_SheetName1   As String = "ToDo"
Public Const C_SheetName2   As String = "Stack"
Public Const C_ToDoColumn1  As String = "#"
Public Const C_ToDoColumn2  As String = "日付"
Public Const C_ToDoColumn3  As String = "作業分類"
Public Const C_ToDoColumn4  As String = "作業内容"
Public Const C_ToDoColumn5  As String = "工数"
Public Const C_ToDoColumn6  As String = "ステータス"
Public Const C_ToDoColumn7  As String = "備考"
Public Const cntRowToDo     As Integer = 10
Public Const cntRowStack    As Integer = 100

'ToDoファイル作成マクロ
Public Sub subCreateToDoFile()
    Dim wbToDo          As Workbook        '作成ToDoファイル
    Dim wsToDo          As Worksheet
    Dim wsStack         As Worksheet
    Dim strFileName     As String
    Dim strFilePath     As String
    Dim cntError        As Integer
    'On Error GoTo lblError
        
    '画面遷移：無
    Application.ScreenUpdating = False
    
    'ファイル作成
    cntError = 1
    strFilePath = Environ("UserProfile") & "\Desktop\"
    strFileName = InputBox("ファイル名を入力してください", "ToDoファイル作成マクロ実行", "【ToDo】XXXXX_yyyymmdd.xlsx")
    If strFileName = "" Then
        cntError = 5
        GoTo lblError
    End If
    Set wbToDo = Workbooks.Add
    wbToDo.SaveAs strFilePath & strFileName
    
    'シート追加
    'シート「ToDo」
    cntError = 2
    wbToDo.Worksheets(1).Name = C_SheetName1
    Set wsToDo = wbToDo.Worksheets(C_SheetName1)
    cntError = 3
    If fncCreateToDo(wsToDo, cntRowToDo) = False Then GoTo lblError
    wsToDo.Tab.Color = RGB(169, 208, 142)
    wsToDo.Range("A1:G1").Interior.Color = RGB(169, 208, 142)

    'シート「Stack」
    cntError = 2
    wbToDo.Worksheets.Add after:=wsToDo
    wbToDo.Worksheets(2).Name = C_SheetName2
    Set wsStack = wbToDo.Worksheets(C_SheetName2)
    cntError = 4
    If fncCreateToDo(wsStack, cntRowStack) = False Then GoTo lblError
    wsStack.Tab.Color = RGB(155, 194, 250)
    wsStack.Range("A1:G1").Interior.Color = RGB(155, 194, 250)
    wsToDo.Select
    
    'ToDo一覧の「作業分類」列に、Stackにある作業分類からドロップダウンリストを作成・追加する。
    'ドロップダウンリスト
    cntError = 3
    With wsToDo.Range("C2:C" & cntRowToDo + 1)
        .Validation.Delete
        .Validation.Add Type:=xlValidateList, Operator:=xlBetween, _
                        Formula1:="=Stack!$C$2:$C$" & cntRowStack + 2
        .Validation.IMEMode = xlIMEModeHiragana
        .Validation.ShowError = False
    End With
    
    '「Stack退避」ボタン追加
    cntError = 6
    ActiveSheet.Buttons.Add(955.2, 19.2, 94.2, 61.2).Select
    Selection.OnAction = "subMoveToStack"
    Selection.Characters.Text = "Stack"
    
    GoTo lblEnd
    
lblError:
    'エラー別メッセージ出力
    Select Case cntError
        'ファイル作成エラー
        Case 1
            'メッセージ：非表示
            Application.DisplayAlerts = False
            wbToDo.Close
            MsgBox "既に同じ名前のファイル名が存在する為、" & vbLf & "処理を中断しました。", vbInformation
        'シート追加エラー
        Case 2
            MsgBox "シート作成中にエラーが起きました。", vbExclamation
        '表作成エラー
        Case 3
            MsgBox "ToDo一覧作成中にエラーが起きました。", vbExclamation
        'Stack表作成エラー
        Case 4
            MsgBox "Stack表作成中にエラーが起きました。", vbExclamation
        '処理中断
        Case 5
            MsgBox "処理を中断しました。", vbInformation
        'マクロ追加エラー
        Case 6
            MsgBox "マクロ追加中にエラーが起きました。", vbExclamation
        'その他エラー
        Case Else
            MsgBox "ToDoファイル作成中にエラーが起きました。", vbExclamation
    End Select
    GoTo lblEnd
    
lblEnd:
    wsToDo.Range("A1").Select
    wbToDo.Save
    
    '画面遷移：有、メッセージ：表示
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

'ToDo表作成
Private Function fncCreateToDo(ByVal impSheet As Worksheet, ByVal impCntRows) As Boolean
    'On Error GoTo lblError
    fncCreateToDo = False

    With impSheet
        '見出し
        .Range("A1").Value = C_ToDoColumn1
        .Range("B1").Value = C_ToDoColumn2
        .Range("C1").Value = C_ToDoColumn3
        .Range("D1").Value = C_ToDoColumn4
        .Range("E1").Value = C_ToDoColumn5
        .Range("F1").Value = C_ToDoColumn6
        .Range("G1").Value = C_ToDoColumn7
        .Range("A1:G1").Font.Bold = True
        .Range("E1").HorizontalAlignment = xlLeft
        '行数
        .Range("A2:A" & impCntRows + 1).Formula = "=ROW()-1"
        '罫線
        .Range("A1:G" & impCntRows + 1).Borders.LineStyle = xlContinuous
        .Range("A1:G" & impCntRows + 1).BorderAround Weight:=xlMedium
        '列幅
        .Columns("A:A").ColumnWidth = 2.5
        .Columns("B:B").ColumnWidth = 8
        .Columns("C:C").ColumnWidth = 10
        .Columns("D:D").ColumnWidth = 43
        .Columns("E:E").ColumnWidth = 8
        .Columns("F:F").ColumnWidth = 6
        .Columns("G:G").ColumnWidth = 54
        
        'テーブル化
        impSheet.ListObjects.Add(xlSrcRange, Range("A1:G" & impCntRows + 1), , xlYes).Name = impSheet.Name
        impSheet.ListObjects(impSheet.Name).TableStyle = ""
        
        '日付
        '表示形式
        .Range("B2:B" & impCntRows + 1).NumberFormatLocal = "m/d(aaa)"
        '入力規則
        With .Range("B2:B" & impCntRows + 1).Validation
            .Delete
            .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator:=xlBetween
            .IMEMode = xlIMEModeOff
        End With
        
        '工数
        '入力規則
        With .Range("E2:E" & impCntRows + 1)
            .HorizontalAlignment = xlCenter
            .Validation.Delete
            .Validation.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator:=xlBetween
            .Validation.IMEMode = xlIMEModeOff
        End With
        'サマリ
        .Range("E" & impCntRows + 3).Formula = "=SUM(" & impSheet.Name & "[" & C_ToDoColumn5 & "])"
        .Range("E" & impCntRows + 2).Delete
        .Range("E" & impCntRows + 2).Font.Color = RGB(191, 191, 191)
        '表示形式
        .Range("E2:E" & impCntRows + 2).NumberFormatLocal = "0.00"
        
        'ステータス
        '条件付き書式
        With .Range("A2:G" & impCntRows + 1)
            .FormatConditions.Delete
            .FormatConditions.Add Type:=xlExpression, Formula1:="=$F2=""完了"""
            .FormatConditions(1).Interior.Color = RGB(191, 191, 191)
            .FormatConditions(1).StopIfTrue = False
            .FormatConditions.Add Type:=xlExpression, Formula1:="=$F2=""仕掛中"""
            .FormatConditions(2).Interior.Color = RGB(255, 230, 153)
            .FormatConditions(2).StopIfTrue = False
        End With
        'ドロップダウンリスト
        With .Range("F2:F" & impCntRows + 1)
            .HorizontalAlignment = xlCenter
            .Validation.Delete
            .Validation.Add Type:=xlValidateList, Operator:=xlBetween, _
                            Formula1:="未着手,仕掛中,保留,完了"
            .Validation.IMEMode = xlIMEModeHiragana
            .Validation.ShowError = False
        End With
        
    End With
    
    fncCreateToDo = True
    
lblError:
End Function

'Stackへ退避
Public Sub subMoveToStack()
        
    MsgBox "Stackに移動させました！"
    
End Sub