【ExcelVBA】長期間のタイムチャート描画スクリプト

はじめに

以下で条件付き書式を用いてタイムチャートを描画する方法は記載しましたが今回はExcelVBA(マクロ)で実装しました。

条件付き書式の場合はカスタマイズは難しいものの、VBAにすれば細かい制御が可能になります。（例えば長時間作業の場合は色を変える、1時間毎に数値を振る）

環境情報

Microsoft Visual Basic for Application 7.1

フォーマット前提

描画に用いる情報は以下です。

A	B	C	D	E
作業項目	作業場所	クリティカルパス	開始時刻	終了時刻

例としては以下です。

A	B	C	D	E
DBサーバ停止	東京	Y	2000/01/02 11:20	2000/01/02 11:40

描画でタイムチャートを表現するので描画エリアは横幅を0.5程度にすると見栄えがよくなります。

「クリティカルパスに属しているか否か」は明示的に「Y」で指定すれば描画されるチャートに「*」が表示されるような作りにしています。
また、60分以上の作業に関しては遠目に作業時間の概要が分かるように数値も記載しています。

f:id:mtiit:20200323174801p:plain — クリティカルパスの表現

場所に関しては「東京」や「自宅」とコード上で指定すればSetColor1Cell部分で検知して色を変えるようにしています。

VBAコード

'-------------------------------------------------------------
Const LINE_START_LOW As Integer = 10  '作業IDが始まる行
Const LINE_START_COL As String = "P" 'タイムチャートの開始列 
Const TIME_START As Date = "2000/01/02 00:00" '全体開始時刻
Const TIME_FINISH As Date = "2000/01/06 00:00" '全体終了時刻
Const WORK_START_TIME_COL As String = "D" '作業開始時刻列
Const WORK_FINISH_TIME_COL As String = "E" '作業終了時刻
Const P_CRITICALPATH_COL As String = "C" 'クリティカルパス列
Const WORK_PLACE_COL As String = "B" '作業場所列
Const TIME_ONE_CELL As Integer = 5 'セル一つに対する分数
'------------------------------------------------------------
Const Date_Threshold As Double = 0.000001

Sub Paint_TimeChart()
Application.ScreenUpdating = False

Dim d As Date
d = TIME_START
Dim d_s As Date
Dim d_e As Date
Dim v_row As Integer
Dim v_col As Integer
Dim i As Integer
Dim j As Integer
Dim d_now As Date
Dim d_next As Date
Dim j_start As Integer
Dim j_stop As Integer
Dim deruta_t As Integer
deruta_t = TIME_ONE_CELL
Dim count As Integer

j_start = LINE_START_LOW
j_stop = Range("A10000").End(xlUp).Row
Dim i_stop As Integer
i_stop = Round(1440 * (TIME_FINISH - TIME_START)) / deruta_t

I_WORK_START_TIME_COL = Range(WORK_START_TIME_COL & "1").Column
I_WORK_FINISH_TIME_COL = Range(WORK_FINISH_TIME_COL & "1").Column
I_P_CRITICALPATH_COL = Range(P_CRITICALPATH_COL & "1").Column
I_WORK_PLACE_COL = Range(WORK_PLACE_COL & "1").Column
I_LINE_START_COL = Range(LINE_START_COL & "1").Column

'描画エリアをクリア
Dim stop_area As String
Dim start_area As String
start_area = LINE_START_COL & LINE_START_LOW
i_stop2 = -1 + I_LINE_START_COL + i_stop
stop_area1 = Cells(1, i_stop2).Address(RowAbsolute:=False, ColumnAbsolute:=False)
stop_area1a = Left(stop_area1, Len(stop_area1) - 1)
stop_area = stop_area1a & j_stop
start2stop = start_area & ":" & stop_area
Range(start2stop).Select
    Selection.ClearContents
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

For j = j_start To j_stop
 count = 0
 Dim where As String
 where = Cells(j, I_WORK_PLACE_COL).Value
 Dim critical As String
 critical = Cells(j, I_P_CRITICALPATH_COL).Value
 cal1 = j
 On Error Resume Next
 d_s = Cells(j, I_WORK_START_TIME_COL).Value
 d_e = Cells(j, I_WORK_FINISH_TIME_COL).Value
 Dim d_th As Double
 d_th = Date_Threshold

 For i = 1 To i_stop
  d_now = TIME_START + ((i - 1) * 5 + 2.5) / 1440
  d_next = TIME_START + (i * 5 - 2.5) / 1440
  Dim d_diff1 As Double
  Dim d_diff2 As Double
  d_diff1 = d_s - d_now
  d_diff2 = d_e - d_next
  If d_diff1 > d_th Then
  ElseIf d_diff1 < -d_th Then
   If d_diff2 > d_th Then
    count = count + 1
    Call SetColor1Cell(j, I_LINE_START_COL + i - 1, where)
    Call SetText1Cell(j, I_LINE_START_COL + i - 1, critical, count)
   ElseIf d_diff2 < -d_th Then
   Else
    count = count + 1
    Call SetColor1Cell(j, I_LINE_START_COL + i - 1, where)
    Call SetText1Cell(j, I_LINE_START_COL + i - 1, critical, count)
   End If
  Else
  If d_diff2 > d_th Then
   count = count + 1
   Call SetColor1Cell(j, I_LINE_START_COL + i - 1, where)
   Call SetText1Cell(j, I_LINE_START_COL + i - 1, critical, count)
  ElseIf d_diff2 < -d_th Then
  Else
   count = count + 1
   Call SetColor1Cell(j, I_LINE_START_COL + i - 1, where)
   Call SetText1Cell(j, I_LINE_START_COL + i - 1, critical, count)
  End If
 End If
Next i
Next j
Application.ScreenUpdating = True
End Sub

'色づけ規則
Private Sub SetColor1Cell(ByVal i1 As Integer, ByVal i2 As Integer, ByVal s As String)
Dim objR As Range
Set objR = Cells(i1, i2)
If s = "東京" Then
With objR.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With
ElseIf s = "自宅" Then
 With objR.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With
ElseIf s = "Z" Then
 With objR.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 10040319
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
Else
End If
End Sub

Private Sub SetText1Cell(ByVal i1 As Integer, ByVal i2 As Integer, ByVal s As String, ByVal count As Integer)
Dim objR As Range
Set objR = Cells(i1, i2)
If s = "Y" Then
    Cells(i1, i2) = "'*"
End If
If count = 12 Then
    Cells(i1, i2 - 11) = "'1"
ElseIf count Mod 12 = 1 And count <> 1 Then
    Dim num As Integer
    num = Int(count / 12) + 1
    Cells(i1, i2) = "'" & num
End If
End Sub

Private Sub Clear1Cell(ByVal i1 As Integer, ByVal i2 As Integer)
Dim objR As Range
Set objR = Cells(i1, i2)
With objR.Interior
.Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
objR.ClearContents
End Sub

終わりに

興味がある方はコピペで動かしながら挙動を確認してみてください。

以上、ご参考になれば幸いです。

(O+P)ut

アウトプット