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
