「今さら」なんてない

「自分にもできそう」を伝播させるブログ

Excel VBA タスクペディア的なオフライン用タスク管理ツール メイン機能まとめ

素人コード過ぎてぐちゃぐちゃな物をお見せする訳にはいかないと変に背伸びしようとしていましたが、昨日、このようなツイートから使命感のようなものに火が点きました。

100点満点どころか80点以下の出来栄えですが、僕自身も職場のセキュリティ上あらゆるツールが使えないので素人ながら今も少しずつ自作を進めています。少しでも同様の境遇の方の力になれたらと思い、なりふり構わずまずは60点を取りに行こうと思います。

目次

概要・機能

※一部動作がおかしいところが残っていますが概ねご利用いただけるかと思います、、、

補助機能も続々投稿していきます。

f:id:yoshino-ya:20180620050226p:plain

  • アウトライナーとしても使える(グループを折畳・展開できる)

  • タスク1行目にNextActionを表示

  • ボール持ち

  • タスク毎の見積時間の小計を各タスク1行目に表示

  • 担当者名ごとに1週間分の見積時間を表示

  • タスク1行目の結果、備考欄で合否が簡単にわかる
    サブタスクの結果欄の"合格","不合格"というワードの有無で抽出しています。
    不要であればここをコメント化or削除して下さい

    '関数の追加:結果詳細の有無
       Cells(Rs, "J").Formula = _
           "=IF(COUNTA($J" & Rs + 1 & ":$J" & Re - 1 & ")=0, ""結果詳細なし"",IF(COUNTIF($J" & Rs + 1 & ":$J" & Re - 1 & ",""*不合格*"") ,""不合格:詳細確認はグループを展開して下さい。"" ,IF(COUNTIF($J" & Rs + 1 & ":$J" & Re - 1 & ",""*合格*""),""合格:詳細確認はグループを展開して下さい。"",""結果詳細はあるが合否判定の記載なし"")))"

やること

"マスタ"というシートの用意

標準モジュールのコピペ

  1. Excelシート上でAlt+F11を押す

  2. メニューバー→挿入→標準モジュール

  3. 真っ白なエディタに貼り付ける

ショートカットの割り当て

ショートカット割当方法はこちらをどうぞ

yoshino-ya.hatenablog.com

※ショートカット反映には一度別ブックか別シートに切り替えて戻ってくる必要があります
ショートカットを実行するとここまで作成されます(担当、基準日は手入力)

標準モジュールにコピペするコード

一部まるごと拝借している部分があります。→拝借元

www.shegolab.jp

Option Explicit
    Public Rs As Long, Rm As Long, Re As Long '開始・終了行
    Public Rlast As Long, Clast As Variant
    Public r As Long, C As Long
    Global ScreenUptate As Integer
    Public Main_タスク名 As String
    Public Main_分類 As String
    Public Main_詳細 As String
    Public Main_担当 As String
    Public Main_発生 As String
    Public Main_締切 As String
    Public Main_見積時間 As String
    Public Main_予定 As String
    Public Main_完了 As String
    Public Main_結果、備考 As String
    Public Main_保存先 As String
    Public 選択拡張 As Boolean
    Public Const タイトル行 = 7
    Public 見積時間フィルタ用担当者名
    ' 項番階層の区切り文字
    Const NUMBER_SEPARATOR = "-"
    ' Const NUMBER_SEPARATOR = "."

Sub 画面更新_グループ化_罫線()
    Dim 現在のセル行, 現在のセル列

    '列No-名称
        Main_タスク名 = "A"
        Main_分類 = "B"
        Main_詳細 = "C"
        Main_担当 = "D"
        Main_発生 = "E"
        Main_締切 = "F"
        Main_見積時間 = "G"
        Main_予定 = "H"
        Main_完了 = "I"
        Main_結果、備考 = "J"
        Main_保存先 = "K"

    '画面更新非表示
        Application.ScreenUpdating = False
        ScreenUptate = 0
    
    '前置き
        現在のセル行 = ActiveCell.Row
        現在のセル列 = ActiveCell.Column
        
        見積時間フィルタ用担当者名 = Range("B4").Value
        
        Call 前置き
            
    '初期化・罫線3
        Call 初期化
        
    'ループ前 変数初期化-----
        Cells(タイトル行 + 2, 2).Activate
        Rs = タイトル行 + 1
        Re = タイトル行 + 2
    'ループ1----------------
        Do Until Re >= Rlast
            Call B列の整理
        Loop
        'ループ1終----------
        
    'ループ前 変数初期化-----
        Cells(タイトル行 + 1, 1).Activate
        Rs = タイトル行 + 1
        Re = タイトル行 + 2
    'ループ2----------------
        Do Until Re > Rlast
            Call A列の整理
        Loop
        'ループ2終了--------
        
    '仕上げ
        Call 罫線仕上げ
'        Call アクティブ行列色付け
        Call 担当着色
        Call 締切超過を赤にする
        Call 終了タスクを灰色にする
        Call タイトル行上をTC1風にする
        
        Cells.Select
        Call アウトライン_列下げ階層
        Columns("L:P").Hidden = True
        
        Range("B8").Select
        ActiveWindow.FreezePanes = True
        
    'アクティブセルの初期化
        Cells(現在のセル行, 現在のセル列).Select
        ActiveSheet.Outline.ShowLevels RowLevels:=1
        
    '画面更新有効化
        Application.ScreenUpdating = True

End Sub


Sub B列の整理()
    C = 2   'B列に対して処理をする

    Do Until Re >= Rlast
     '空行でないセル探し(上)
         If Rs < 3 Then Exit Sub
         Do While Cells(Rs, C).Value = ""
             Rs = Rs - 1
         Loop
             
     '空行でないセル探し(下)
         Do While Cells(Re, C).Value = "" And Cells(Re, C - 1).Value = ""   'A,B列が共に空白になるまで
            If Re > Rlast Then
                 Re = Rlast + 1     'あとで-1するので補正しておく
                 Exit Do
            End If
            Re = Re + 1
         Loop
         
    'セルのマージ
        Range(Cells(Rs, C), Cells(Re - 1, C)).Merge     'Re行は空白ではないので1つ戻った行まで
      
    '罫線追加:タスク以降の列-----------------------------
        With Cells(Rs, C).Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlHairline
        End With
   
    '次のグループへ
        Rs = Re
        Re = Re + 1
        
    Loop
    
End Sub
       
Sub A列の整理()
    Dim 補正行 As Long, マージサイズ As Integer
    C = 1

    '空行でないセル探し(上)
        If Rs <= 1 Then Exit Sub     'タイトル行下は非表示にできなくする
        Do While Cells(Rs, C).Value = ""
            Rs = Rs - 1
        Loop
    
    '空行でないセル探し(下)
        Do While Cells(Re, C).Value = ""
            If Re > Rlast Then
                Re = Rlast + 1    'あとで-1するので補正しておく
                Exit Do
            End If
            Re = Re + 1
        Loop

    'NextActionの追加
        '既にあればパス(空白の場合もパス)
            If Cells(Rs, C + 1).Value <> "NextAction→" Then
                
                If Cells(Rs, C + 1).Value <> "" Then
                'UnMerge前にマージサイズを控えておく
                    マージサイズ = Cells(Rs, C + 1).MergeArea.Count
                '行の追加
                    Cells(Rs, C + 1).UnMerge
                    Range(Cells(Rs, "A"), Cells(Rs, "X")).Insert Shift:=xlDown
                '行を追加した分、ReとRlastを+1しておく
                    Re = Re + 1
                    Rlast = Rlast + 1
                'B列1つ目をUnmergeした分をMergeし直す
                    補正行 = Rs + マージサイズ
                    If 補正行 > Rlast Then: 補正行 = Rlast
                    Range(Cells(Rs + 1, C + 1), Cells(補正行, C + 1)).Merge
                
                End If
                
                '"NextAction→"と入力
                    Cells(Rs, 2).Value = "NextAction→"
            End If
            
    '入力規則の追加:ボール持ち
        With Cells(Rs, 4).Validation
            .Add Type:=xlValidateList, _
                Formula1:="先方,当方,いつか,未到来,完了,非タスク"
        End With
        Cells(Rs, 4).ShrinkToFit = True
        
    '見積時間の小計を算出する
       Cells(Rs, "G").Formula = _
        "=ROUND(SUMIF($I" & Rs + 1 & ":$I" & Re - 1 & ","""",$G" & Rs + 1 & ":$G" & Re - 1 & ")/60,1)&""h"""
                
        Cells(Rs, "G").Font.ColorIndex = 5
        
    'グループ先頭行のみ残見積の削除(循環参照対策)
        Cells(Rs, "O").Value = ""
        
    '関数の追加:結果詳細の有無
       Cells(Rs, "J").Formula = _
           "=IF(COUNTA($J" & Rs + 1 & ":$J" & Re - 1 & ")=0, ""結果詳細なし"",IF(COUNTIF($J" & Rs + 1 & ":$J" & Re - 1 & ",""*不合格*"") ,""不合格:詳細確認はグループを展開して下さい。"" ,IF(COUNTIF($J" & Rs + 1 & ":$J" & Re - 1 & ",""*合格*""),""合格:詳細確認はグループを展開して下さい。"",""結果詳細はあるが合否判定の記載なし"")))"
'
    'NextAction行の探索
        Dim rNext As Integer
        rNext = Rs + 1
        
        '1行目が完了なら完了。以降の処理をしない
            If Cells(Rs, Main_完了).Value <> "" Then
                Cells(Rs, Main_担当).Value = "完了"
            Else
            'フロー
                '1.完了="" & 2.詳細<>"" & 3.担当<>""AND <>"-" & 4.予定<>""
                Do Until rNext >= Re - 1
                    If Cells(rNext, Main_完了).Value = "" _
                        And Cells(rNext, Main_詳細).Value <> "" _
                        And Cells(rNext, Main_担当).Value <> "" _
                        And Cells(rNext, Main_担当).Value <> "-" Then
'                        And Cells(rNext, Main_予定).Value <> "" Then
                            Exit Do
                    Else
                        rNext = rNext + 1
                    End If
                Loop
            
            'NextActionの転記
                'C:詳細
                    Cells(Rs, Main_詳細).Value = Cells(rNext, Main_詳細).Value
                'F:締切
                    Cells(Rs, Main_締切).Value = Cells(rNext, Main_締切).Value
                'G:予定
                    Cells(Rs, Main_予定).Value = Cells(rNext, Main_予定).Value
                'D:担当
                    Dim サブタスク
                    With Cells(rNext, "D")
                        If Cells(rNext, "I").Value <> "" Then
                            Cells(Rs, Main_担当).Value = "完了"
                        Else
                            Select Case .Value
                                Case Is = "未到来"
                                    Cells(Rs, Main_担当).Value = "未到来"
                                Case Is = "いつか"
                                    Cells(Rs, Main_担当).Value = "いつか"
                                Case Is = 見積時間フィルタ用担当者名
                                    Cells(Rs, Main_担当).Value = "当方"
                                Case Is = ""
                                    Cells(Rs, Main_担当).Value = "非タスク"
                                Case Is = "-"
                                    Cells(Rs, Main_担当).Value = "非タスク"
                                Case Else
                                    Cells(Rs, Main_担当).Value = "先方"
                            End Select
                        End If
                    End With
        End If
            
    'A列仕上げ:セルのマージ
        Range(Cells(Rs, C), Cells(Re - 1, C)).Merge
        
        
        
    '外枠 太線--------------------------
        With Range(Cells(Rs, 1), Cells(Re - 1, Clast))
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
        End With
    '------------------------------------
    
    '太字にする
        Range(Cells(Rs, 1), Cells(Rs, Clast)).Font.Bold = True
    
    '次のグループへ
        Rs = Re
        Re = Re + 1

End Sub
Sub 罫線仕上げ()
    
'細線--------------------------------------------
    For C = 1 To 14 Step 1
        With Range(Cells(タイトル行, C), Cells(Rlast, C)).Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    Next
    
    With Range(Cells(タイトル行, "E"), Cells(タイトル行, "J")).Borders(xlBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With

'太線--------------------------------------------
'タイトル行
        With Range(Cells(タイトル行, 1), Cells(タイトル行, Clast))
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        End With
            '------------------------------------
    
    'D-F列(担当、発生、締切)
        With Range(Cells(タイトル行, "D"), Cells(Rlast, "F"))
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent6
                .TintAndShade = 0.799981688894314
                .PatternTintAndShade = 0
            End With
        End With
            '------------------------------------
    'G-I(見積時間、予定、完了)
        With Range(Cells(タイトル行, "G"), Cells(Rlast, "I"))
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Interior
                .PatternColorIndex = xlAutomatic
                .Color = 10092543
            End With
        End With
    'J(結果、備考)
        With Range(Cells(タイトル行, "J"), Cells(Rlast, "J"))
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent6
                .TintAndShade = 0.799981688894314
                .PatternTintAndShade = 0
            End With
        End With
            '------------------------------------
    'K(保存先)
        With Range(Cells(タイトル行, "K"), Cells(Rlast, "K"))
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        End With
            '------------------------------------
                            
    '全体
        With Range(Cells(タイトル行, 1), Cells(Rlast, "K"))
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        End With
            '------------------------------------
    '中央寄せ
        Range(Cells(タイトル行, "D"), Cells(Rlast, "I")) _
            .HorizontalAlignment = xlCenter
        
    '行の高さ指定(改行対策)
        Cells.RowHeight = 12
        Rows(タイトル行).RowHeight = 25  '1行目だけ大きくする
        Cells(タイトル行, "G").WrapText = True    '見積[分]だけ折返しONにしておく
        
    '列の幅指定
        Columns("A").ColumnWidth = 30
        Columns("B").ColumnWidth = 20
        Columns("K").ColumnWidth = 8
        Columns("C").ColumnWidth = 65
        Columns("D:I").ColumnWidth = 3.5
        Columns("J").ColumnWidth = 35
        Columns("K").ColumnWidth = 10
        
    'フォントサイズ指定
        Cells.Font.Size = 9
        'A-B列はセル幅に併せて縮小する
        Range("A:B").ShrinkToFit = True
        Range("D:I").ShrinkToFit = True
        
'セルの位置を初期化する
    Cells(タイトル行 + 1, 1).Activate
    Rs = タイトル行 + 1
    Re = タイトル行 + 2
    
End Sub


Sub 前置き()
    Dim タイトル行の内容, タイトル行列変数
    Cells.ClearOutline
    Cells.FormatConditions.Delete
    
    'タイトル行の付与
        タイトル行の内容 = Split("タスク名,分類,詳細(方法・条件など),担当, 発生, 締切, 見積[分], 予定, 完了, 結果、備考, ファイル保存先, 開始, 終了, 予定順", ",")
        For タイトル行列変数 = 0 To UBound(タイトル行の内容) - 1
            Cells(7, タイトル行列変数 + 1).Value = タイトル行の内容(タイトル行列変数)
        Next タイトル行列変数
        
    '非表示シートの作成
        Dim ws As Worksheet, flag As Boolean
        For Each ws In Worksheets
            If ws.Name = "非表示" Then flag = True
        Next ws
        
        If flag = False Then
            With Worksheets.Add()
                .Name = "非表示"
            End With
            With Sheets("非表示")
                .Range("A1").Value = "最終行"
                .Range("A2").Value = "ブック名"
                .Visible = False
            End With
            
            Dim OldSheet As Worksheet
            Set OldSheet = ActiveSheet
            Worksheets.Add
            OldSheet.Activate
        End If
    
    '最終列
        Clast = "N"
    '最下行探し
        Rlast = WorksheetFunction.Max( _
            Cells(Rows.Count, 1).End(xlUp).Row, _
            Cells(Rows.Count, 2).End(xlUp).Row, _
            Cells(Rows.Count, 3).End(xlUp).Row)
        Sheets("非表示").Range("B1").Value = Rlast
        
    'レジストリに格納しておく
        SaveSetting "MyMacro", "マスタ", "最終行", Rlast
        SaveSetting "MyMacro", "マスタ", "最終列", Clast
        
    '次の処理の準備
        Cells(タイトル行 + 1, 1).Activate '
        Rs = タイトル行 + 2           '
        
End Sub

Sub 初期化()
    Dim flag
    'Cells.UnMerge        '結合セル全て解除
    Range(Cells(タイトル行, 1), Cells(Rlast, Clast)).UnMerge
    With ActiveSheet.Range(Cells(タイトル行 + 1, "D"), Cells(Rlast, "N"))
        .AutoFilter                                            'フィルタ無効化
        flag = 0
    End With
    'Cells.ClearFormats
    Cells.Validation.Delete
    
    'サブタスク以降の列
        With Range(Cells(タイトル行 + 2, 3), Cells(Rlast, Clast))
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlHairline
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlHairline
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlHairline
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlHairline
            End With
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlHairline
            End With
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlHairline
            End With
        End With
        
End Sub

Sub 終了タスクを灰色にする()
    '条件付き書式の付与
        With Range(Cells(タイトル行 + 1, 1), Cells(Rlast, Clast))
            .Interior.PatternColorIndex = xlAutomatic    '基本は白色にする
            .FormatConditions.Add Type:=xlExpression, Formula1:="=$I8<>"""""
            .FormatConditions(.FormatConditions.Count).SetFirstPriority
            
            With .FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -0.149998474074526
            End With
            .FormatConditions(1).StopIfTrue = False
        End With
            
    '日付欄の書式設定 m/dにする
        Range(Cells(タイトル行, "E"), Cells(Rlast, "F")) _
            .NumberFormatLocal = "m/d;@"
        Range(Cells(タイトル行, "H"), Cells(Rlast, "I")) _
            .NumberFormatLocal = "m/d;@"
        Columns("L:M").NumberFormatLocal = "hh:mm;@"

End Sub

Sub 担当着色()
    
    With Range(Cells(タイトル行 + 1, 4), Cells(Rlast, 4))
        .FormatConditions.Add Type:=xlTextString, String:="当方", _
            TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 3381759
            .TintAndShade = 0
        End With
        
        .FormatConditions.Add Type:=xlTextString, String:="先方", _
            TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 16764057
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        
        .FormatConditions.Add Type:=xlTextString, String:="完了", _
            TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
        End With
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorLight1
            .TintAndShade = 0
        End With

        .FormatConditions.Add Type:=xlTextString, String:="未到来", _
            TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent3
            .TintAndShade = 0.399945066682943
        End With
        
        .FormatConditions.Add Type:=xlTextString, String:="いつか", _
            TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 16751103
            .TintAndShade = 0
        End With
    End With
End Sub

Sub 締切超過を赤にする()
    Const 自分 = "INDIRECT(""RC"", False)"
    
    '条件付き書書記を付与する
        With Range(Cells(タイトル行 + 1, 6), Cells(Rlast, 6))
            .FormatConditions.Add Type:=xlExpression, Formula1:= _
            "=AND(" & 自分 & "<> """", " & 自分 & "<=TODAY()+6)"
                
            .FormatConditions(.FormatConditions.Count).SetFirstPriority
            With .FormatConditions(1).Font
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = 0
            End With
            With .FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .Color = 49407
                .TintAndShade = 0
            End With
        End With
        
        With Range(Cells(タイトル行 + 1, 6), Cells(Rlast, 6))
            .FormatConditions.Add Type:=xlExpression, Formula1:= _
            "=AND(" & 自分 & "<> """", " & 自分 & "<=TODAY())"
                
            .FormatConditions(.FormatConditions.Count).SetFirstPriority
            With .FormatConditions(1).Font
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = 0
            End With
            With .FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .Color = 255
                .TintAndShade = 0
            End With
        End With
    
    '予定も同様の条件付き書書記を付与する
        With Range(Cells(タイトル行 + 1, 8), Cells(Rlast, 8))
            .FormatConditions.Add Type:=xlExpression, Formula1:= _
            "=AND(" & 自分 & "<> """", " & 自分 & "<=TODAY()+6)"
                
            .FormatConditions(.FormatConditions.Count).SetFirstPriority
            With .FormatConditions(1).Font
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = 0
            End With
            With .FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .Color = 49407
                .TintAndShade = 0
            End With
        End With

        With Range(Cells(タイトル行 + 1, 8), Cells(Rlast, 8))
            .FormatConditions.Add Type:=xlExpression, Formula1:= _
            "=AND(" & 自分 & "<> """", " & 自分 & "<=TODAY())"
                
            .FormatConditions(.FormatConditions.Count).SetFirstPriority
            With .FormatConditions(1).Font
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = 0
            End With
            With .FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .Color = 255
                .TintAndShade = 0
            End With
        End With

End Sub

Sub ハイパーリンクを青にする()
    If InStr(C.Formula, "HYPERLINK") > 0 Then
End Sub

Sub タイトル行上をTC1風にする()
    Dim day As Integer
    
    '見積
        Range("A1").Value = "見積"
        Range("B1").Formula = "=SUMIFS(G:G,H:H, $B$5,D:D,$B$4)/60"
    '■済み
        Range("A2").Value = "■済み"
        Range("B2").Formula = "=SUMIFS(G:G,I:I, $B$5,D:D,$B$4)/60"
    '□残り
        Range("A3").Value = "□残り"
        Range("B3").Formula = "=B1-B2"
    '担当
        Range("A4").Value = "担当"
    '基準日
        Range("A5").Value = "基準日"
        Range("B5").NumberFormatLocal = "mm/dd"
        
        Range("B1:B3").NumberFormatLocal = "0.00"

    For day = 1 To 5
        '明日~5日後までの日付
            Cells(day, "C").Formula = _
                "=TEXT($B$5+" & day & ",""mm/dd"") & "" "" & TEXT(MID(""日月火水木金土"",WEEKDAY($B$5+" & day & "),1),0)"
        
        '明日~5日後までの日別見積
            Cells(day, "D").Formula = _
                "=SUMIFS(G:G,H:H,LEFT(C" & day & ",5),D:D,$B$4)/60"
    Next day
    
    '表示形式の付与
        Range("C1:C5").NumberFormatLocal = "mm/dd"
        Range("D1:D5").NumberFormatLocal = "0.00"
    
    '寄せ
        With Range("A1:A5,C1:C5")
            .HorizontalAlignment = xlRight
        End With
        With Range("B1:B5,D1:D5")
            .HorizontalAlignment = xlLeft
        End With

    '罫線と着色
        'A
        Call 罫線をひく("B1:B5,D1:D5", xlHairline, True, True, True, True, True, True)
        With Range("B1:B5")
            With .Interior
                .PatternColorIndex = xlAutomatic
                .Color = 10092543
            End With
        End With
        
        'B
            Call 罫線をひく("B1:B5,D1:D5", xlMedium, True, True, True, True, False, False)

        With Range("D1:D5")
            
            With .Interior
                .PatternColorIndex = xlAutomatic
                .Color = 10092543
            End With
        End With
        
End Sub

Sub 罫線sub呼び出し()
    Call 罫線をひく("A1:B5", xlThin, True, True, True, True, True, True)
End Sub

Sub 罫線をひく(範囲, 太さ, _
    Optional 左 As Boolean, _
    Optional 右 As Boolean, _
    Optional 上 As Boolean, _
    Optional 下 As Boolean, _
    Optional 水平 As Boolean, _
    Optional 鉛直 As Boolean)
    
    With Range(範囲)
        If 左 = True Then
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = 太さ
            End With
        End If
        If 上 = True Then
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = 太さ
            End With
        End If
        If 下 = True Then
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = 太さ
            End With
        End If
        If 右 = True Then
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = 太さ
            End With
        End If
        If 水平 = True Then
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = 太さ
            End With
        End If
        If 鉛直 = True Then
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = 太さ
            End With
        End If
        End With
        
End Sub


Sub アウトライン_インデント階層()
    outlineTree probe:="indentLevel"
End Sub

Sub アウトライン_列下げ階層()
    outlineTree probe:="columnPosition"
End Sub

Sub アウトライン_項番階層()
    outlineTree probe:="multiNumbered"
End Sub

Private Sub outlineTree(probe As String)
    If TypeName(Selection) <> "Range" Then Beep: Exit Sub
    
    Dim titleRng As Range
    Set titleRng = Intersect(ActiveSheet.UsedRange, Selection.Areas(1))
    If titleRng Is Nothing Then Beep: Exit Sub
    
    Application.ScreenUpdating = False
    
    ActiveSheet.Outline.SummaryRow = xlAbove
    titleRng.ClearOutline
    Call traverseList(titleRng, 0, probe:=probe)
    
    Application.ScreenUpdating = True
End Sub

Private Function traverseList(curRng As Range, curLevel As Integer, probe As String, Optional doProc As String = "doGroup") As Range
    Dim i As Integer
    For i = 1 To curRng.Rows.Count - 1
        Dim subRng As Range
        Dim nextLevel As Integer
        
        Set subRng = Intersect(curRng, curRng.Offset(i))
        nextLevel = Application.Run(probe, subRng.Rows(1), curLevel)
        If nextLevel > curLevel Then
            Set subRng = traverseList(subRng, nextLevel, probe, doProc)
            Set subRng = Application.Run(doProc, subRng, nextLevel)
            i = i - 1 + subRng.Rows.Count
        ElseIf nextLevel < curLevel Then
            Exit For
        End If
    Next
    Set traverseList = curRng.Resize(i)
End Function

Private Function indentLevel(itemRow As Range, level As Integer) As Integer
    With itemRow.Cells(1)
        indentLevel = IIf(IsEmpty(.Value), 8, .indentLevel)
    End With
End Function

Private Function columnPosition(itemRow As Range, level As Integer) As Integer
    columnPosition = 0
    Dim C As Range
    For Each C In itemRow.Cells
        If Not IsEmpty(C) Then Exit Function
        columnPosition = columnPosition + 1
    Next
End Function

Private Function multiNumbered(itemRow As Range, level As Integer) As Integer
    With itemRow.Cells(1)
        multiNumbered = IIf(IsEmpty(.Value), 8, UBound(Split(.Text, NUMBER_SEPARATOR)))
    End With
End Function

Private Function doGroup(ByVal rng As Range, level As Integer) As Range
    rng.Rows.Group
    Set doGroup = rng
End Function

Private Function doInsertParent(ByVal rng As Range, level As Integer) As Range
    rng.Rows(1).EntireRow.Insert
    Set doInsert = Range(rng, rng.Offset(-1))
End Function

追加機能一覧

本記事で作成したExcelブック用の補助機能をまとめましたので併せてご利用下さい。

  1. ショートカットの割当

  2. 行の追加・削除

  3. 情報管理ツールへの拡張:フォルダ一括作成&フォルダを開く

  4. フィルタリング

  5. 折畳・展開 & ズームイン・アウト

  6. インデント上げ下げ

  7. ビュー切替

  8. テンプレート挿入

以上です。

まだまだ荒削りで、しばらく使っているとだんだん重くなるのでシート内容を別シートにコピーして引っ越した後、マスタシートを削除するなどのメンテナンスが必要な状態です。