【Excel VBA】スケジュール表で進捗管理矢印を自動で入れるアラフィフ生産技術の日常

本ページはプロモーションが含まれています

Excelでスケジュール表を作成して進捗管理する作業を簡単にする方法を紹介します。

Excel スケジュール表で進捗管理
実際に使ってみる
まとめ

Excel スケジュール表で進捗管理

こちらが完成形です。
D4のセルから右方向に日付。
「業務内容」の開始日と終了日を入力すると矢印を自動作成します。

スケジュール表の作成

まずはスケジュール表の作成。
D4のセルから右方向に日付を入力。
〇月〇日で入力してくださいね。

日付の書式設定は「d」だけにします。

【Excel VBA】スケジュール表で進捗管理矢印を自動で入れる　日付の表示形式

１日だけ月の表示

1日だけ月の表示（Dec）は条件付き書式で行っています。
「ホーム」タブの条件付き書式です。

まずは月初だけ月の表示を行う方法。
「数式を使用して・・・」を選択。
ルール下記を入力します。

=DAY(D4)=1

【Excel VBA】スケジュール表で進捗管理矢印を自動で入れる　数式を使用して

書式設定はこちら。

[$-en-US]mmm/d;@

【Excel VBA】スケジュール表で進捗管理矢印を自動で入れる　月名の表示方法

土日の色付け

曜日による色付けはこちらを参照してください。

【EXCEL】日付を入れたら曜日を自動で表示土日の色を変える方法も

進捗の矢印を自動で入れるVBA

VBAをつかったことがない人も安心してください。
コピペでできますよ。

はじめてVBAをつかう人は「開発」というタブを表示すると便利です。
こちらに方法を書いていますので参考にしてください。

【EXCEL】EXCEL VBAの始め方＆保存方法開発タブを表示

VBAの画面はこんな感じ。

今回紹介するのはすべて「標準モジュール」に入力します。
挿入　→　標準モジュール

【Excel VBA】スケジュール表で進捗管理矢印を自動で入れる　標準モジュール

こちらをコピペして下さい。

Sub 日付から矢印作成()

    Dim rng1 As Range
    Dim dt As Range
    Dim rng2 As Range
    Dim r As Long
    Dim foundCell1 As Range
    Dim startCol As Long
    Dim foundCell2 As Range
    Dim endCol As Long
    Dim targetRng As Range
    Dim i As Integer

    Set rng1 = ActiveSheet.Range(Range("D4"), Range("D4").End(xlToRight)) ' 日付入力範囲
    Set dt = ActiveSheet.Range("C1") ' 今日の日付入力セル
    i = 5
    Do While Cells(i, 1) <> ""
        If Cells(i, 2) <> "" Then
            Set foundCell1 = rng1.Find(Cells(i, 2), , xlFormulas, xlPart) ' 開始日で検索した時の該当セル
            startCol = foundCell1.Column ' 検索該当セルの列番号
            If Cells(i, 3) = "" Then ' 終了日が空欄の場合
                Set foundCell2 = rng1.Find(dt, , xlFormulas, xlPart)  ' 今日の日付で検索した時の該当セル
                endCol = foundCell2.Column '検索該当セルの列番号
            Else ' 終了日が空欄ではない場合
                Set foundCell2 = rng1.Find(Cells(i, 3), , xlFormulas, xlPart) ' 終了日で検索した時の該当セル
                endCol = foundCell2.Column '検索該当セルの列番号
            End If
            ActiveSheet.Range(Cells(i, startCol), Cells(i, endCol)).Select
            If Cells(i, 3) <> "" Then
                Set targetRng = Selection ' 開始日から終了日までのセル範囲
                With ActiveSheet.Shapes.AddLine(targetRng.Left, targetRng.Top + targetRng.Height / 2, _
                    targetRng.Left + targetRng.Width, targetRng.Top + targetRng.Height / 2).Line
                    .ForeColor.RGB = RGB(255, 0, 0) ' 線の色
                    .Weight = 3 ' 線の太さ
                    .EndArrowheadStyle = 2 ' 線の終点のスタイル
                End With
            Else
                Set targetRng = Selection ' 開始日から終了日までのセル範囲
                With ActiveSheet.Shapes.AddLine(targetRng.Left, targetRng.Top + targetRng.Height / 2, _
                    targetRng.Left + targetRng.Width, targetRng.Top + targetRng.Height / 2).Line
                    .ForeColor.RGB = RGB(0, 255, 0) ' 線の色
                    .Weight = 3 ' 線の太さ
                    .EndArrowheadStyle = 1 ' 線の終点のスタイル
                End With
            End If
        End If
        i = i + 1
    Loop
'    Next rng2
    
End Sub


Sub 更新処理()
Dim i As Shape
For Each i In ActiveSheet.Shapes
  If Not Intersect(i.TopLeftCell, Range(Cells(5, 4), Cells(50, 300))) Is Nothing _
          And Not Intersect(i.BottomRightCell, Range(Cells(5, 4), Cells(50, 300))) Is Nothing Then
        i.Select False
  End If
Next i
With Selection.ShapeRange.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(0, 0, 0)
        .Transparency = 0
End With
Selection.ShapeRange.IncrementTop 3
End Sub

今回のコード作成には下記サイトを参考にさせていただきました。
Excelでガントチャートの矢印を自動作成する方法
 特定の範囲内にある図形を全て選択する