-- 設定値
シート名(E11)
開始行(E12)
終了行(E13)
開始時刻列(E14)
終了時刻列(E15)
チャート開始列(E16)
チャート終了列(E17)
チャート開始列時刻(E18)
1セルの時間(分)(E19)
着色する色(E20)
-- ロジック(時間間隔60分の場合)
開始時刻がX時以上X+1時未満ならX時のセルを開始セルとする
終了時刻がX時より大きくX+1時以下ならX時のセルを終了セルとする
開始セルと終了セルに挟まれたすべてのセルも着色する
-- 1. 開発タブの挿入でボタンを作成
※ActiveXコントロールのものを使用する
-- 2. デザインモードONで作成したボタンをダブルクリックするとエディタが開くので下記コードを記載。デザインモードOFFで実行
Option Explicit
Private Sub CommandButton1_Click()
'画面を更新しない
Application.ScreenUpdating = False
'確認メッセージを表示しない
Application.DisplayAlerts = False
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim strFolderPath As String
strFolderPath = ThisWorkbook.Path & "\test"
'testフォルダがない場合、作成
If Dir(strFolderPath, vbDirectory) = "" Then
MkDir strFolderPath
End If
'testファイルがある場合、削除
If Dir(strFolderPath & "\test.xlsx") <> "" Then
Kill strFolderPath & "\test.xlsx"
End If
'■テストファイル作成
Call createFile(strFolderPath & "\test.xlsx")
ChDir strFolderPath
'■ファイル選択
Dim file_mei As Variant
file_mei = Application.GetOpenFilename( _
FileFilter:="Excelファイル, *.xls;*.xlsx", _
Title:="ファイルを選択してください", _
MultiSelect:=False)
If VarType(file_mei) = vbBoolean Then
GoTo EE
End If
Debug.Print "file_mei", file_mei
'■設定値の取得
Dim i_sheet_mei As String
Dim i_s_row As Long
Dim i_e_row As Long
Dim i_s_timecol As String
Dim i_e_timecol As String
Dim i_cha_s_col As String
Dim i_cha_e_col As String
Dim i_cha_s_time As String
Dim i_interval As Long
Dim i_color As Long
'シート名 (E11) ガントチャート
i_sheet_mei = Trim(Range("E11").Value)
'開始行 (E12) 3
i_s_row = Trim(Range("E12").Value)
'終了行 (E13) 7
i_e_row = Trim(Range("E13").Value)
'開始時刻列 (E14) C
i_s_timecol = Trim(Range("E14").Value)
'終了時刻列 (E15) D
i_e_timecol = Trim(Range("E15").Value)
'チャート開始列 (E16) F
i_cha_s_col = Trim(Range("E16").Value)
'チャート終了列 (E17) L
i_cha_e_col = Trim(Range("E17").Value)
'チャート開始列時刻 (E18) 9:00
i_cha_s_time = Trim(Range("E18").Value)
'1セルの時間(分)(E19) 60
i_interval = Trim(Range("E19").Value)
'着色する色 (E20)
i_color = Trim(Range("E20").Interior.Color)
Debug.Print "i_color", i_color
'■選択したファイルの処理対象シートを開く
Dim wb As Workbook
Dim sheet As Variant
Dim sh As Worksheet
Set wb = Workbooks.Open(file_mei)
For Each sheet In wb.Worksheets
If Trim(sheet.Name) = i_sheet_mei Then
Set sh = sheet
Exit For
End If
Next sheet
If sh Is Nothing Then
wb.Close
MsgBox "シートが存在しません"
GoTo EE
End If
'■チャート範囲の色クリア
sh.Range(i_cha_s_col & i_s_row & ":" & i_cha_e_col & i_s_row).Interior.ColorIndex = 0
'■開始時刻列,終了時刻列,チャート開始列,チャート終了列を文字→数値に変換する
Dim s_timecol As Long
Dim e_timecol As Long
Dim cha_s_col As Long
Dim cha_e_col As Long
s_timecol = Columns(i_s_timecol).Column
e_timecol = Columns(i_e_timecol).Column
cha_s_col = Columns(i_cha_s_col).Column
cha_e_col = Columns(i_cha_e_col).Column
Debug.Print "s_timecol, e_timecol, cha_s_col, cha_e_col", s_timecol, e_timecol, cha_s_col, cha_e_col
Dim i As Long
Dim j As Long
Dim k As Long
'■ガントチャート作成
For i = i_s_row To i_e_row
'着色開始セル列番号
Dim color_s_col As Long
'着色終了セル列番号
Dim color_e_col As Long
'開始時刻、終了時刻の値
Dim s_time As String
Dim e_time As String
color_s_col = 0
color_e_col = 0
s_time = sh.Cells(i, s_timecol).Value
e_time = sh.Cells(i, e_timecol).Value
Debug.Print "s_time, e_time", s_time, e_time
For j = cha_s_col To cha_e_col
''開始時刻がX時以上X+1時未満ならX時のセルを開始セルとする
''終了時刻がX時より大きくX+1時以下ならX時のセルを終了セルとする
''開始セルと終了セルに挟まれたすべてのセルも着色する
'セル時刻(対象セル)
Dim c1_time As String
c1_time = i_cha_s_time + i_interval / 24 / 60 * (j - cha_s_col)
'セル時刻(対象セルの次のセル)
Dim c2_time As String
c2_time = i_cha_s_time + i_interval / 24 / 60 * (j - cha_s_col + 1)
Debug.Print "j, c1_time, c2_time", j, c1_time, c2_time
If s_time >= c1_time And s_time < c2_time Then
color_s_col = j
End If
If e_time > c1_time And e_time <= c2_time Then
color_e_col = j
End If
Next j
If color_s_col <> 0 Or color_e_col <> 0 Then
'開始セルのみの場合、終了セルはチャート範囲の終了列番号とする
If color_e_col = 0 Then
color_e_col = cha_e_col
End If
'終了セルのみの場合、開始セルはチャート範囲の開始列番号とする
If color_s_col = 0 Then
color_s_col = cha_s_col
End If
'着色実行
For k = color_s_col To color_e_col
sh.Cells(i, k).Interior.Color = i_color
Next k
End If
Next i
'ワークブック保存
wb.Save
wb.Close
MsgBox "処理完了"
EE:
'確認メッセージを表示する
Application.DisplayAlerts = True
'画面を更新する
Application.ScreenUpdating = True
End Sub
'テストファイル作成関数
Private Sub createFile(filepath As String)
'ワークブック作成
Dim wb As Workbook
Set wb = Workbooks.Add
'シート追加
Dim sh As Worksheet
Set sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
'シート名変更
Worksheets(Worksheets.Count).Name = "ガントチャート"
'セル書き込み
With Worksheets(Worksheets.Count)
.Range("B2").Value = "項番"
.Range("C2").Value = "開始時刻"
.Range("D2").Value = "終了時刻"
.Range("F2").Value = "9:00"
.Range("G2").Value = "10:00"
.Range("H2").Value = "11:00"
.Range("I2").Value = "12:00"
.Range("J2").Value = "13:00"
.Range("K2").Value = "14:00"
.Range("L2").Value = "15:00"
.Range("B3").Value = "1"
.Range("C3").Value = "9:00"
.Range("D3").Value = "9:10"
.Range("B4").Value = "2"
.Range("C4").Value = "9:10"
.Range("D4").Value = "11:00"
.Range("B5").Value = "3"
.Range("C5").Value = "11:00"
.Range("D5").Value = "12:05"
.Range("B6").Value = "4"
.Range("C6").Value = "12:05"
.Range("D6").Value = "12:55"
.Range("B7").Value = "5"
.Range("C7").Value = "12:55"
.Range("D7").Value = "15:00"
End With
'ワークブックを保存して閉じる
wb.Close True, filepath
ThisWorkbook.Activate
End Sub
