仕事でプロジェクトツールが全く使われていなく、導入する予定もない部署への応援が決定した。
取り急ぎ、ガントチャートを作れるソフトが欲しかったのでExcelで作れるか試してみた。まぁちゃんとしたソフトがインストールできればそれでよかったんだけど、難しそうなので自作でしのげればと思う。
作成途中だけど、日付を入れるとその日の色が変わる程度なら作れたので一旦、ここまでとしておこうと思う。正直どんな管理項目が必要かもわからないので、そのあたりは融通が利くように列名の定義をできるようにしておいた。さて、必要そうな機能（まぁ色変えるだけなんだけど）の実装は終わったのであとはコードのコピペして完成品を作ろう。
＜概要＞
・処理開始時にメインシートに定義しておいた、色を変えたい日付範囲の項目名を探す
・列があとからどんどん追加されていくので「ガントチャート」部分の開始列が分かるように「【ガントチャート開始】」という文字列を入れておく。（消さないでね・・・）
・日付セルの場合は加算、減算ができるので基準日から開始日、終了日からの差を見ればどの列範囲かもわかるのでそこの色を変える。
・キーワードの設定（〆切日、その他色々）もできればいいな。（願望）
・範囲を複数持たせていろんな意味の色を塗れるようにする。発注期間の色、使用期限の色、利用期間の色、などなど（できればいいな）
＜プログラム とりあえず4行目の色を変えるだけ＞
Private fintBetween1Start As Integer
Private fintBetween1End As Integer
Private fintBetween2Start As Integer
Private fintBetween2End As Integer
Private fintBetween3Start As Integer
Private fintBetween3End As Integer
Private fintBetween4Start As Integer
Private fintBetween4End As Integer
Private fintBetween5Start As Integer
Private fintBetween5End As Integer
Private fdatePrjStartDate As Date
Private Const SHEETNAME_DATA As String = "データ"
Private Const SHEETNAME_MAIN As String = "メイン"
Private Const HeaderRow As Integer = 3
Private Const DataStartRow As Integer = 4
Private Const FINT_MAX_COLUMN_IN_DATE As Integer = 1500
'メインシート
Private Const FINT_KEYWORD_START_ROW As Integer = 6
Private Const FINT_KEYWORD_ITEMNAME_COLUMN As Integer = 12
Private Const FINT_KEYWORD_ITEMVALUE_COLUMN As Integer = 13
'データシート
Private fintGanttChartStartColumn As Integer
Private Const KEY_WORD_MAX_COUNT As Integer = 100 '何件でもいいがとりあえずの総件数
Private Sub Main()
Call InitializeSetting
Call InitializeRowStatus(4)
Call SetRow(4)
End Sub
Private Sub SetRow(ByVal lngRow As Long)
Dim lngDiff As Long
Dim lngEndDiff As Long
Dim rng As Range
Dim rngColor As Range
'範囲１の内容を色塗り
lngDiff = DateDiff("d", fdatePrjStartDate, Sheets(SHEETNAME_DATA).Cells(lngRow, fintBetween1Start))
lngEndDiff = DateDiff("d", fdatePrjStartDate, Sheets(SHEETNAME_DATA).Cells(lngRow, fintBetween1End))
Set rngColor = Sheets(SHEETNAME_MAIN).Range("F7")
Set rng = Sheets(SHEETNAME_DATA).Range(Sheets(SHEETNAME_DATA).Cells(lngRow, fintGanttChartStartColumn + lngDiff), Sheets(SHEETNAME_DATA).Cells(lngRow, fintGanttChartStartColumn + lngEndDiff))
With rng.Interior
.Color = rngColor.Interior.Color
.TintAndShade = rngColor.Interior.TintAndShade
.PatternTintAndShade = rngColor.Interior.PatternTintAndShade
End With
'キーワードを設定（作成中）
' Dim i, j As Long
' Dim strKeyWord As String
' Dim strCellValue As String
' Dim strColumns As String
' Dim strColumnArr() As String
'
' For i = 0 To 100
' strKeyWord = Sheets(SHEETNAME_MAIN).Cells(i + FINT_KEYWORD_START_ROW, FINT_KEYWORD_ITEMVALUE_COLUMN).Value
' If strKeyWord = "" Then Exit Sub
' strColumns = GetSearchStringCell(strKeyWord, True, CStr(lngRow) & ":" & CStr(lngRow), SHEETNAME_DATA)
'
' strColumnArr = Split(strColumns, ",")
' For j = 0 To UBound(strColumnArr)
' If Sheets(SHEETNAME_DATA).Cells(lngRow, strColumnArr(j)).Value = strKeyWord Then
' Sheets(SHEETNAME_DATA).Cells(lngRow, strColumnArr(j)).Value = ""
' End If
' Next
' Next
End Sub
Private Sub InitializeSetting()
Dim strGanttChartStartDay As String
strGanttChartStartDay = GetSearchStringCell("【ガントチャート開始】", True, "1:1", SHEETNAME_DATA)
fintGanttChartStartColumn = CInt(strGanttChartStartDay)
fdatePrjStartDate = Sheets(SHEETNAME_MAIN).Range("F4").Value
fintBetween1Start = GetColumnNo(Sheets(SHEETNAME_MAIN).Range("F5").Value)
fintBetween1End = GetColumnNo(Sheets(SHEETNAME_MAIN).Range("F6").Value)
End Sub
Private Function GetColumnNo(ByVal strColName As String)
Dim i As Long
GetColumnNo = 0
For i = 1 To 100
If Sheets(SHEETNAME_DATA).Cells(HeaderRow, i).Value = strColName Then
GetColumnNo = i
Exit Function
End If
Next
End Function
Private Function GetStartGanntChartColumn(ByVal strColName As String)
Dim i As Long
GetColumnNo = 0
For i = 1 To 300
If Sheets(SHEETNAME_DATA).Cells(1, i).Value = strColName Then
GetColumnNo = i
Exit Function
End If
Next
End Function
'---------------------------------------------------------
' 指定行の初期化処理を行う
'---------------------------------------------------------
Private Sub InitializeRowStatus(ByVal lngRow As Long)
'Rowの背景色を全て削除
Call ClearBackgroundInRow(lngRow)
'キーワードを削除
Call ClearKeyWordInRow(lngRow)
End Sub
Private Sub ClearBackgroundInRow(ByVal lngRow As Long)
Dim rng As Range
Dim strRange As String
Set rng = Sheets(SHEETNAME_DATA).Range(Cells(lngRow, fintGanttChartStartColumn), Sheets(SHEETNAME_DATA).Cells(lngRow, FINT_MAX_COLUMN_IN_DATE))
'背景色削除
With rng.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
'---------------------------------------------------------
' キーワードとして設定されている内容をすべて削除する
'---------------------------------------------------------
Private Sub ClearKeyWordInRow(ByVal lngRow As Long)
Dim i, j As Long
Dim strKeyWord As String
Dim strCellValue As String
Dim strColumns As String
Dim strColumnArr() As String
For i = 0 To 100
strKeyWord = Sheets(SHEETNAME_MAIN).Cells(i + FINT_KEYWORD_START_ROW, FINT_KEYWORD_ITEMVALUE_COLUMN).Value
If strKeyWord = "" Then Exit Sub
strColumns = GetSearchStringCell(strKeyWord, True, CStr(lngRow) & ":" & CStr(lngRow), SHEETNAME_DATA)
strColumnArr = Split(strColumns, ",")
For j = 0 To UBound(strColumnArr)
If Sheets(SHEETNAME_DATA).Cells(lngRow, strColumnArr(j)).Value = strKeyWord Then
Sheets(SHEETNAME_DATA).Cells(lngRow, strColumnArr(j)).Value = ""
End If
Next
Next
End Sub
'---------------------------------------------------------
' 日付セルを検索
' シート名と行か列位置を指定し検索する。該当した行、列位置をカンマ区切りで返す。
' １件ずつループしながらIf関数で１行ずつ判定するより圧倒的に高速
' 複数条件は対応外なので、この関数で該当行を絞ったうえで、If関数で詳細なチェックをかけたほうが高速になる
' 利用例）GetSearchDateCell("2020/08/01",False,"A:A","データ")
' 戻り値例）4,15,20
'---------------------------------------------------------
Public Function GetSearchDateCell(ByVal datValue As Date, ByVal blnSearchInRow As Boolean, ByVal strRange As String, ByVal strSheetName As String) As String
Dim rng As Range
Dim adr As String
Dim strResult As String
GetSearchDateCell = ""
If blnSearchInRow = True Then
Set rng = Sheets(strSheetName).Rows(strRange).Find(datValue)
Else
Set rng = Sheets(strSheetName).Columns(strRange).Find(datValue)
End If
If rng Is Nothing Then
Exit Function
Else
adr = rng.Address
If blnSearchInRow = True Then
strResult = rng.Column
Else
strResult = rng.Row
End If
End If
Do
If blnSearchInRow = True Then
Set rng = Sheets(strSheetName).Rows(strRange).FindNext(After:=rng)
Else
Set rng = Sheets(strSheetName).Columns(strRange).FindNext(After:=rng)
End If
If rng.Address = adr Then
Exit Do
Else
If blnSearchInRow = True Then
strResult = strResult & "," & rng.Column
Else
strResult = strResult & "," & rng.Row
End If
End If
Loop
GetSearchDateCell = strResult
End Function
'---------------------------------------------------------
' 文字列セルを検索
' シート名と行か列位置を指定し検索する。該当した行、列位置をカンマ区切りで返す。
' １件ずつループしながらIf関数で１行ずつ判定するより圧倒的に高速
' 複数条件は対応外なので、この関数で該当行を絞ったうえで、If関数で詳細なチェックをかけたほうが高速になる
' 利用例）GetSearchDateCell("2020/08/01",False,"A:A","データ")
' 戻り値例）4,15,20
'---------------------------------------------------------
Public Function GetSearchStringCell(ByVal strValue As String, ByVal blnSearchInRow As Boolean, ByVal strRange As String, ByVal strSheetName As String) As String
Dim rng As Range
Dim adr As String
Dim strResult As String
GetSearchStringCell = ""
If blnSearchInRow = True Then
Set rng = Sheets(strSheetName).Rows(strRange).Find(strValue)
Else
Set rng = Sheets(strSheetName).Columns(strRange).Find(strValue)
End If
If rng Is Nothing Then
Exit Function
Else
adr = rng.Address
If blnSearchInRow = True Then
strResult = rng.Column
Else
strResult = rng.Row
End If
End If
Do
If blnSearchInRow = True Then
Set rng = Sheets(strSheetName).Rows(strRange).FindNext(After:=rng)
Else
Set rng = Sheets(strSheetName).Columns(strRange).FindNext(After:=rng)
End If
If rng.Address = adr Then
Exit Do
Else
If blnSearchInRow = True Then
strResult = strResult & "," & rng.Column
Else
strResult = strResult & "," & rng.Row
End If
End If
Loop
GetSearchStringCell = strResult
End Function
