エクセル小僧：VBAで条件付き書式を設定(改) [コンピューター]
【前記事】
エクセル小僧：VBAで条件付き書式を設定
https://cheese999.blog.ss-blog.jp/2022-01-10#comments
に対して、次の変更をしました。
１．変更のあった行だけ、条件付き書式を設定するようにした。
２．色情報(RGB)を2次元配列に設定して、その情報で色設定するようにした。
※行列番号は上記イメージと異なります。
【マクロ（標準モジュール）】
Sub mySSetFormatCondition1(Optional Start_Row1 As Long = 8, Optional End_Row1 As Long = 48)
'【機能】条件付き書式を設定する（体温）
'【引数】
' Start_Row1 As Long ' 開始行（デフォルト値：8）
' End_Row1 As Long ' 終了行（デフォルト値：48）
'【変数】
Dim mySheetName1 As String ' シート名
Dim Range_StartDay As String ' 開始日のRange名
Dim Row_Day1 As Long ' 日付の行番号
Dim Start_Col1 As Long ' 1日の列
Dim End_Col1 As Long ' 31日の列
Dim Col_Str1 As String ' 列アルファベット
Dim Col_NyuYoku1() As Variant ' 入浴曜日の列アルファベット
Dim fcs As FormatConditions ' 条件付き書式
Dim fc1 As FormatCondition ' 条件付き書式
Dim myColor2() As Variant ' 色情報(RGB)
Dim myCount2() As Variant ' 各色の配列の添え字
Dim myMaxCount2() As Variant ' 色情報配列の1次元の添え字､各色の配列の添え字の最大値
Dim f As Font
Dim i, j As Long
'【実行コード】
Range_StartDay = "_StartDay1"
Row_Day1 = Range(Range_StartDay).Row
mySheetName1 = ActiveSheet.Name ' アクティブシート名
Start_Col1 = Range("G:G").Column
End_Col1 = Range("AK:AK").Column
Col_NyuYoku1() = Array("AM", "AN", "AO", "AP", "AQ", "AR", "AS")
myColor2() = myFSetColor1(myCount2(), myMaxCount2()) ' 色情報
' Debug.Print "myColor2(1, 0)=" & myColor2(5, 2)
For i = Start_Row1 To End_Row1
For j = Start_Col1 To End_Col1
Col_Str1 = ColNum2Let(j) ' 列アルファベット
With Worksheets(mySheetName1).Range(Col_Str1 & i)
.FormatConditions.Delete ' 条件付き書式を削除
' 条件1 : 1日と月が違う日は、文字色=白にして、文字を表示しない
Set fc1 = .FormatConditions.Add(Type:=xlExpression, Formula1:="=MONTH(" & Range_StartDay & ")<>MONTH(" & Col_Str1 & Row_Day1 & ")")
fc1.Font.Color = RGB(myColor2(1, 0), myColor2(1, 1), myColor2(1, 2)) ' 文字色=白
fc1.Interior.Color = RGB(myColor2(1, 0), myColor2(1, 1), myColor2(1, 2)) ' 背景色=白
fc1.StopIfTrue = True ' 条件を満たす場合は停止=真
' 条件2 : 月が○なら、月のセルを水色で塗りつぶす
If Range(Col_NyuYoku1(1) & i).Value = "○" Then
Set fc1 = .FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & Col_Str1 & Row_Day1 & ")=2")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(2, 0), myColor2(2, 1), myColor2(2, 2)) ' 背景色=水色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
End If
' 条件3 : 木が○なら、木のセルを水色で塗りつぶす
If Range(Col_NyuYoku1(4) & i).Value = "○" Then
Set fc1 = .FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & Col_Str1 & Row_Day1 & ")=5")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(2, 0), myColor2(2, 1), myColor2(2, 2)) ' 背景色=水色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
End If
' 条件4 : 火が○なら、火のセルをピンクで塗りつぶす
If Range(Col_NyuYoku1(2) & i).Value = "○" Then
Set fc1 = .FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & Col_Str1 & Row_Day1 & ")=3")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(3, 0), myColor2(3, 1), myColor2(3, 2)) ' 背景色=ピンク
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
End If
' 条件5 : 金が○なら、金のセルをピンクで塗りつぶす
If Range(Col_NyuYoku1(5) & i).Value = "○" Then
Set fc1 = .FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & Col_Str1 & Row_Day1 & ")=6")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(3, 0), myColor2(3, 1), myColor2(3, 2)) ' 背景色=ピンク
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
End If
' 条件6 : 水が○なら、水のセルを黄色で塗りつぶす
If Range(Col_NyuYoku1(3) & i).Value = "○" Then
Set fc1 = .FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & Col_Str1 & Row_Day1 & ")=4")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(4, 0), myColor2(4, 1), myColor2(4, 2)) ' 背景色=黄色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
End If
' 条件7 : 土が○なら、土のセルを黄色で塗りつぶす
If Range(Col_NyuYoku1(6) & i).Value = "○" Then
Set fc1 = .FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & Col_Str1 & Row_Day1 & ")=7")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(4, 0), myColor2(4, 1), myColor2(4, 2)) ' 背景色=黄色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
End If
' 条件8 : 日が○なら、日のセルを緑色で塗りつぶす
If Range(Col_NyuYoku1(0) & i).Value = "○" Then
Set fc1 = .FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & Col_Str1 & Row_Day1 & ")=1")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(5, 0), myColor2(5, 1), myColor2(5, 2)) ' 背景色=緑色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
End If
'
' Set fcs = .FormatConditions
' Debug.Print "fcs.Count=" & (fcs.Count)
' Set fc1 = fcs(2)
' Debug.Print "fc1.Type=" & fc1.Type
' Debug.Print "fc1.Operator=" & fc1.Operator
' Debug.Print "fc1.Formula1=" & fc1.Formula1
' Debug.Print "fc1.StopIfTrue=" & fc1.StopIfTrue
' Set f = fc1.Font
' Debug.Print "fc1.Font.Color=" & fc1.Font.Color
' Debug.Print "fc1.Interior.color=" & fc1.Interior.Color
End With
Next j
Next i
End Sub
Sub mySSetFormatCondition2()
'【機能】条件付き書式を設定する（日付曜日）
'【変数】
Dim mySheetName1 As String ' シート名
Dim fc1 As FormatCondition ' 条件付き書式
Dim myColor2() As Variant ' 色情報(RGB)
Dim myCount2() As Variant ' 各色の配列の添え字
Dim myMaxCount2() As Variant ' 色情報配列の1次元の添え字､各色の配列の添え字の最大値
Dim i As Long
'【実行コード】
mySheetName1 = ActiveSheet.Name ' アクティブシート名
myColor2() = myFSetColor1(myCount2(), myMaxCount2()) ' 色情報
With Worksheets(mySheetName1).Range("_日付曜日")
.FormatConditions.Delete ' 条件付き書式を削除
For i = 1 To .Count
' 条件1 : 1日と月が違う日は、文字色=白にして、文字を表示しない
Set fc1 = .Item(i).FormatConditions.Add(Type:=xlExpression, Formula1:="=OR(MONTH(" & .Item(1).Address & ")<>MONTH(" & .Item(i).Address & _
"), YEAR(" & .Item(1).Address & ")<>YEAR(" & .Item(i).Address & "))")
fc1.Font.Color = RGB(myColor2(1, 0), myColor2(1, 1), myColor2(1, 2)) ' 文字色=白
fc1.Interior.Color = RGB(myColor2(1, 0), myColor2(1, 1), myColor2(1, 2)) ' 背景色=白
fc1.StopIfTrue = True ' 条件を満たす場合は停止=真
' 条件2 : 月曜なら、水色で塗りつぶす
Set fc1 = .Item(i).FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & .Item(i).Address & ")=2")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(2, 0), myColor2(2, 1), myColor2(2, 2)) ' 背景色=水色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
' 条件3 : 木なら、水色で塗りつぶす
Set fc1 = .Item(i).FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & .Item(i).Address & ")=5")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(2, 0), myColor2(2, 1), myColor2(2, 2)) ' 背景色=水色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
' 条件4 : 火なら、ピンクで塗りつぶす
Set fc1 = .Item(i).FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & .Item(i).Address & ")=3")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(3, 0), myColor2(3, 1), myColor2(3, 2)) ' 背景色=ピンク
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
' 条件5 : 金なら、ピンクで塗りつぶす
Set fc1 = .Item(i).FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & .Item(i).Address & ")=6")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(3, 0), myColor2(3, 1), myColor2(3, 2)) ' 背景色=ピンク
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
' 条件6 : 水なら、黄色で塗りつぶす
Set fc1 = .Item(i).FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & .Item(i).Address & ")=4")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(4, 0), myColor2(4, 1), myColor2(4, 2)) ' 背景色=黄色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
' 条件7 : 土なら、黄色で塗りつぶす
Set fc1 = .Item(i).FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & .Item(i).Address & ")=7")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(4, 0), myColor2(4, 1), myColor2(4, 2)) ' 背景色=黄色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
' 条件8 : 日なら、緑色で塗りつぶす
Set fc1 = .Item(i).FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & .Item(i).Address & ")=1")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(5, 0), myColor2(5, 1), myColor2(5, 2)) ' 背景色=緑色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
Next i
'Debug.Print ".Item(1).Address=" & .Item(1).Address
End With
End Sub
Sub mySSetFormatCondition3()
'【機能】条件付き書式を設定する（体温）
Call mySSetFormatCondition1
End Sub
Function ColNum2Let(ByVal colNum As Long, Optional colStr As String = "") As String
'【機能】列番号⇒列アルファベット変換(1から始まる10進数⇒A-Zの26進数)
' 1:A, 2:B - 26:Z, 27:AA - 703:AAA
' (27-1)/26 = 1余0 ⇒A
' (1-1)/26 = 0余0 ⇒A
' 再帰呼び出し
'【引数】
' colNum : 列番号、1から始まる10進数
' colStr : 列アルファベット、省略可、省略した場合、空文字列
If colNum = 0 Then
' 列番号が0なら、列アルファベットを返す
ColNum2Let = colStr
Else
' 列番号から1引いて26で割った余をアルファベット変換し、今までの列アルファベットを連結
' AのASCIIコード：65
colStr = Chr(65 + (colNum - 1) Mod 26) & colStr
' 列番号から1引いて26で割った商を新しい列番号にする
colNum = (colNum - 1) \ 26
' 再帰呼び出し
ColNum2Let = ColNum2Let(colNum, colStr)
End If
End Function
Function myFSetColor1(ByRef myCount2() As Variant, ByRef myMaxCount2() As Variant) As Variant()
'【機能】色情報の二次元配列を返す
'【引数】
' myCount2() : 各色の配列の添え字
' myMaxCount2() : 色情報配列の１次元の添え字、各色の配列の添え字の最大値
'【変数】
Dim myColor1(), myColor2() As Variant ' 色情報(RGB)
Dim myCount2_1() As Variant ' 各色の配列の添え字
Dim myMaxCount2_1() As Variant ' 色情報配列の１次元の添え字、各色の配列の添え字の最大値
'【実行コード】
' 色情報：黒(0, 0, 0), 白(255, 255, 255), 水色(204, 255, 255)
' ピンク(255, 235, 255), 黄色(255, 255, 205), 緑色(206, 255, 206)
myColor1 = Array( _
Array(0, 0, 0), Array(255, 255, 255), _
Array(204, 255, 255), Array(255, 235, 255), _
Array(255, 255, 205), Array(206, 255, 206) _
)
' 入れ子になっている1次元配列から2次元配列への変換
myColor2() = myTransArray1(myColor1(), myCount2_1(), myMaxCount2_1())
myCount2() = myCount2_1()
myMaxCount2() = myMaxCount2_1()
myFSetColor1 = myColor2()
End Function
Function myTransArray1(ByRef myArray1() As Variant, ByRef myCount2() As Variant, _
ByRef myMaxCount2() As Variant) As Variant()
'【機能】入れ子になっている1次元配列から2次元配列への変換
'【引数】
' myArray1() : 入れ子になっている1次元配列 Array(Array(), Array() - Array())
' myCount2() : 入れ子の内側の各配列の添え字
' myMaxCount2() : 入れ子の外側の配列の添え字、入れ子の内側の各配列の添え字の最大値
'【変数】
Dim i, j As Long ' 整数
Dim myArray2() As Variant ' 出力配列（２次元）
'【実行コード】
ReDim myMaxCount2(1) ' 配列をReDim
myMaxCount2(0) = UBound(myArray1) ' 入れ子の外側の配列の添え字
ReDim myCount2(myMaxCount2(0)) ' 配列をReDim
myMaxCount2(1) = 0 ' 入れ子の内側の各配列の添え字の最大値=0
For j = 0 To myMaxCount2(0)
myCount2(j) = UBound(myArray1(j)) ' 入れ子の内側の各配列の添え字
If myCount2(j) > myMaxCount2(1) Then myMaxCount2(1) = myCount2(j) ' その添え字は最大値か？
Next j
ReDim myArray2(myMaxCount2(0), myMaxCount2(1)) ' 出力配列（２次元）をReDim
For j = 0 To myMaxCount2(0)
For i = 0 To myCount2(j)
myArray2(j, i) = myArray1(j)(i) ' 出力配列（２次元）に各要素の値を代入
Next i
Next j
myTransArray1 = myArray2()
End Function
【マクロ（ワークシート）】
Private Sub Worksheet_Change(ByVal Target As Range)
If Not (Intersect(Target, Range("_入浴曜日")) Is Nothing) Then
' Debug.Print "Target.Address=" & Target.Address
Debug.Print "Target.Rows(1).Row=" & Target.Rows(1).Row
Debug.Print "Target.Rows(Target.Rows.Count).Row=" & Target.Rows(Target.Rows.Count).Row
' _入浴曜日のセル範囲で変化の発生した行だけ、条件付き書式を変更（体温）
Call mySSetFormatCondition1(Target.Rows(1).Row, Target.Rows(Target.Rows.Count).Row)
End If
If Not (Intersect(Target, Range("_StartYear1")) Is Nothing) Then
Call mySSetFormatCondition2 '条件付き書式を設定する（日付曜日）
' Debug.Print "mySSetFormatCondition2"
' Debug.Print "Target.Value=" & Target.Value
End If
If Not (Intersect(Target, Range("_StartMonth1")) Is Nothing) Then
Call mySSetFormatCondition2 '条件付き書式を設定する（日付曜日）
' Debug.Print "mySSetFormatCondition2"
' Debug.Print "Target.Value=" & Target.Value
End If
End Sub
エクセル小僧：VBAで条件付き書式を設定
https://cheese999.blog.ss-blog.jp/2022-01-10#comments
に対して、次の変更をしました。
１．変更のあった行だけ、条件付き書式を設定するようにした。
２．色情報(RGB)を2次元配列に設定して、その情報で色設定するようにした。
※行列番号は上記イメージと異なります。
【マクロ（標準モジュール）】
Sub mySSetFormatCondition1(Optional Start_Row1 As Long = 8, Optional End_Row1 As Long = 48)
'【機能】条件付き書式を設定する（体温）
'【引数】
' Start_Row1 As Long ' 開始行（デフォルト値：8）
' End_Row1 As Long ' 終了行（デフォルト値：48）
'【変数】
Dim mySheetName1 As String ' シート名
Dim Range_StartDay As String ' 開始日のRange名
Dim Row_Day1 As Long ' 日付の行番号
Dim Start_Col1 As Long ' 1日の列
Dim End_Col1 As Long ' 31日の列
Dim Col_Str1 As String ' 列アルファベット
Dim Col_NyuYoku1() As Variant ' 入浴曜日の列アルファベット
Dim fcs As FormatConditions ' 条件付き書式
Dim fc1 As FormatCondition ' 条件付き書式
Dim myColor2() As Variant ' 色情報(RGB)
Dim myCount2() As Variant ' 各色の配列の添え字
Dim myMaxCount2() As Variant ' 色情報配列の1次元の添え字､各色の配列の添え字の最大値
Dim f As Font
Dim i, j As Long
'【実行コード】
Range_StartDay = "_StartDay1"
Row_Day1 = Range(Range_StartDay).Row
mySheetName1 = ActiveSheet.Name ' アクティブシート名
Start_Col1 = Range("G:G").Column
End_Col1 = Range("AK:AK").Column
Col_NyuYoku1() = Array("AM", "AN", "AO", "AP", "AQ", "AR", "AS")
myColor2() = myFSetColor1(myCount2(), myMaxCount2()) ' 色情報
' Debug.Print "myColor2(1, 0)=" & myColor2(5, 2)
For i = Start_Row1 To End_Row1
For j = Start_Col1 To End_Col1
Col_Str1 = ColNum2Let(j) ' 列アルファベット
With Worksheets(mySheetName1).Range(Col_Str1 & i)
.FormatConditions.Delete ' 条件付き書式を削除
' 条件1 : 1日と月が違う日は、文字色=白にして、文字を表示しない
Set fc1 = .FormatConditions.Add(Type:=xlExpression, Formula1:="=MONTH(" & Range_StartDay & ")<>MONTH(" & Col_Str1 & Row_Day1 & ")")
fc1.Font.Color = RGB(myColor2(1, 0), myColor2(1, 1), myColor2(1, 2)) ' 文字色=白
fc1.Interior.Color = RGB(myColor2(1, 0), myColor2(1, 1), myColor2(1, 2)) ' 背景色=白
fc1.StopIfTrue = True ' 条件を満たす場合は停止=真
' 条件2 : 月が○なら、月のセルを水色で塗りつぶす
If Range(Col_NyuYoku1(1) & i).Value = "○" Then
Set fc1 = .FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & Col_Str1 & Row_Day1 & ")=2")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(2, 0), myColor2(2, 1), myColor2(2, 2)) ' 背景色=水色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
End If
' 条件3 : 木が○なら、木のセルを水色で塗りつぶす
If Range(Col_NyuYoku1(4) & i).Value = "○" Then
Set fc1 = .FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & Col_Str1 & Row_Day1 & ")=5")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(2, 0), myColor2(2, 1), myColor2(2, 2)) ' 背景色=水色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
End If
' 条件4 : 火が○なら、火のセルをピンクで塗りつぶす
If Range(Col_NyuYoku1(2) & i).Value = "○" Then
Set fc1 = .FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & Col_Str1 & Row_Day1 & ")=3")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(3, 0), myColor2(3, 1), myColor2(3, 2)) ' 背景色=ピンク
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
End If
' 条件5 : 金が○なら、金のセルをピンクで塗りつぶす
If Range(Col_NyuYoku1(5) & i).Value = "○" Then
Set fc1 = .FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & Col_Str1 & Row_Day1 & ")=6")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(3, 0), myColor2(3, 1), myColor2(3, 2)) ' 背景色=ピンク
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
End If
' 条件6 : 水が○なら、水のセルを黄色で塗りつぶす
If Range(Col_NyuYoku1(3) & i).Value = "○" Then
Set fc1 = .FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & Col_Str1 & Row_Day1 & ")=4")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(4, 0), myColor2(4, 1), myColor2(4, 2)) ' 背景色=黄色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
End If
' 条件7 : 土が○なら、土のセルを黄色で塗りつぶす
If Range(Col_NyuYoku1(6) & i).Value = "○" Then
Set fc1 = .FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & Col_Str1 & Row_Day1 & ")=7")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(4, 0), myColor2(4, 1), myColor2(4, 2)) ' 背景色=黄色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
End If
' 条件8 : 日が○なら、日のセルを緑色で塗りつぶす
If Range(Col_NyuYoku1(0) & i).Value = "○" Then
Set fc1 = .FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & Col_Str1 & Row_Day1 & ")=1")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(5, 0), myColor2(5, 1), myColor2(5, 2)) ' 背景色=緑色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
End If
'
' Set fcs = .FormatConditions
' Debug.Print "fcs.Count=" & (fcs.Count)
' Set fc1 = fcs(2)
' Debug.Print "fc1.Type=" & fc1.Type
' Debug.Print "fc1.Operator=" & fc1.Operator
' Debug.Print "fc1.Formula1=" & fc1.Formula1
' Debug.Print "fc1.StopIfTrue=" & fc1.StopIfTrue
' Set f = fc1.Font
' Debug.Print "fc1.Font.Color=" & fc1.Font.Color
' Debug.Print "fc1.Interior.color=" & fc1.Interior.Color
End With
Next j
Next i
End Sub
Sub mySSetFormatCondition2()
'【機能】条件付き書式を設定する（日付曜日）
'【変数】
Dim mySheetName1 As String ' シート名
Dim fc1 As FormatCondition ' 条件付き書式
Dim myColor2() As Variant ' 色情報(RGB)
Dim myCount2() As Variant ' 各色の配列の添え字
Dim myMaxCount2() As Variant ' 色情報配列の1次元の添え字､各色の配列の添え字の最大値
Dim i As Long
'【実行コード】
mySheetName1 = ActiveSheet.Name ' アクティブシート名
myColor2() = myFSetColor1(myCount2(), myMaxCount2()) ' 色情報
With Worksheets(mySheetName1).Range("_日付曜日")
.FormatConditions.Delete ' 条件付き書式を削除
For i = 1 To .Count
' 条件1 : 1日と月が違う日は、文字色=白にして、文字を表示しない
Set fc1 = .Item(i).FormatConditions.Add(Type:=xlExpression, Formula1:="=OR(MONTH(" & .Item(1).Address & ")<>MONTH(" & .Item(i).Address & _
"), YEAR(" & .Item(1).Address & ")<>YEAR(" & .Item(i).Address & "))")
fc1.Font.Color = RGB(myColor2(1, 0), myColor2(1, 1), myColor2(1, 2)) ' 文字色=白
fc1.Interior.Color = RGB(myColor2(1, 0), myColor2(1, 1), myColor2(1, 2)) ' 背景色=白
fc1.StopIfTrue = True ' 条件を満たす場合は停止=真
' 条件2 : 月曜なら、水色で塗りつぶす
Set fc1 = .Item(i).FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & .Item(i).Address & ")=2")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(2, 0), myColor2(2, 1), myColor2(2, 2)) ' 背景色=水色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
' 条件3 : 木なら、水色で塗りつぶす
Set fc1 = .Item(i).FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & .Item(i).Address & ")=5")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(2, 0), myColor2(2, 1), myColor2(2, 2)) ' 背景色=水色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
' 条件4 : 火なら、ピンクで塗りつぶす
Set fc1 = .Item(i).FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & .Item(i).Address & ")=3")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(3, 0), myColor2(3, 1), myColor2(3, 2)) ' 背景色=ピンク
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
' 条件5 : 金なら、ピンクで塗りつぶす
Set fc1 = .Item(i).FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & .Item(i).Address & ")=6")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(3, 0), myColor2(3, 1), myColor2(3, 2)) ' 背景色=ピンク
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
' 条件6 : 水なら、黄色で塗りつぶす
Set fc1 = .Item(i).FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & .Item(i).Address & ")=4")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(4, 0), myColor2(4, 1), myColor2(4, 2)) ' 背景色=黄色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
' 条件7 : 土なら、黄色で塗りつぶす
Set fc1 = .Item(i).FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & .Item(i).Address & ")=7")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(4, 0), myColor2(4, 1), myColor2(4, 2)) ' 背景色=黄色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
' 条件8 : 日なら、緑色で塗りつぶす
Set fc1 = .Item(i).FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(" & .Item(i).Address & ")=1")
fc1.Font.Color = RGB(myColor2(0, 0), myColor2(0, 1), myColor2(0, 2)) ' 文字色=黒
fc1.Interior.Color = RGB(myColor2(5, 0), myColor2(5, 1), myColor2(5, 2)) ' 背景色=緑色
fc1.StopIfTrue = False ' 条件を満たす場合は停止=偽
Next i
'Debug.Print ".Item(1).Address=" & .Item(1).Address
End With
End Sub
Sub mySSetFormatCondition3()
'【機能】条件付き書式を設定する（体温）
Call mySSetFormatCondition1
End Sub
Function ColNum2Let(ByVal colNum As Long, Optional colStr As String = "") As String
'【機能】列番号⇒列アルファベット変換(1から始まる10進数⇒A-Zの26進数)
' 1:A, 2:B - 26:Z, 27:AA - 703:AAA
' (27-1)/26 = 1余0 ⇒A
' (1-1)/26 = 0余0 ⇒A
' 再帰呼び出し
'【引数】
' colNum : 列番号、1から始まる10進数
' colStr : 列アルファベット、省略可、省略した場合、空文字列
If colNum = 0 Then
' 列番号が0なら、列アルファベットを返す
ColNum2Let = colStr
Else
' 列番号から1引いて26で割った余をアルファベット変換し、今までの列アルファベットを連結
' AのASCIIコード：65
colStr = Chr(65 + (colNum - 1) Mod 26) & colStr
' 列番号から1引いて26で割った商を新しい列番号にする
colNum = (colNum - 1) \ 26
' 再帰呼び出し
ColNum2Let = ColNum2Let(colNum, colStr)
End If
End Function
Function myFSetColor1(ByRef myCount2() As Variant, ByRef myMaxCount2() As Variant) As Variant()
'【機能】色情報の二次元配列を返す
'【引数】
' myCount2() : 各色の配列の添え字
' myMaxCount2() : 色情報配列の１次元の添え字、各色の配列の添え字の最大値
'【変数】
Dim myColor1(), myColor2() As Variant ' 色情報(RGB)
Dim myCount2_1() As Variant ' 各色の配列の添え字
Dim myMaxCount2_1() As Variant ' 色情報配列の１次元の添え字、各色の配列の添え字の最大値
'【実行コード】
' 色情報：黒(0, 0, 0), 白(255, 255, 255), 水色(204, 255, 255)
' ピンク(255, 235, 255), 黄色(255, 255, 205), 緑色(206, 255, 206)
myColor1 = Array( _
Array(0, 0, 0), Array(255, 255, 255), _
Array(204, 255, 255), Array(255, 235, 255), _
Array(255, 255, 205), Array(206, 255, 206) _
)
' 入れ子になっている1次元配列から2次元配列への変換
myColor2() = myTransArray1(myColor1(), myCount2_1(), myMaxCount2_1())
myCount2() = myCount2_1()
myMaxCount2() = myMaxCount2_1()
myFSetColor1 = myColor2()
End Function
Function myTransArray1(ByRef myArray1() As Variant, ByRef myCount2() As Variant, _
ByRef myMaxCount2() As Variant) As Variant()
'【機能】入れ子になっている1次元配列から2次元配列への変換
'【引数】
' myArray1() : 入れ子になっている1次元配列 Array(Array(), Array() - Array())
' myCount2() : 入れ子の内側の各配列の添え字
' myMaxCount2() : 入れ子の外側の配列の添え字、入れ子の内側の各配列の添え字の最大値
'【変数】
Dim i, j As Long ' 整数
Dim myArray2() As Variant ' 出力配列（２次元）
'【実行コード】
ReDim myMaxCount2(1) ' 配列をReDim
myMaxCount2(0) = UBound(myArray1) ' 入れ子の外側の配列の添え字
ReDim myCount2(myMaxCount2(0)) ' 配列をReDim
myMaxCount2(1) = 0 ' 入れ子の内側の各配列の添え字の最大値=0
For j = 0 To myMaxCount2(0)
myCount2(j) = UBound(myArray1(j)) ' 入れ子の内側の各配列の添え字
If myCount2(j) > myMaxCount2(1) Then myMaxCount2(1) = myCount2(j) ' その添え字は最大値か？
Next j
ReDim myArray2(myMaxCount2(0), myMaxCount2(1)) ' 出力配列（２次元）をReDim
For j = 0 To myMaxCount2(0)
For i = 0 To myCount2(j)
myArray2(j, i) = myArray1(j)(i) ' 出力配列（２次元）に各要素の値を代入
Next i
Next j
myTransArray1 = myArray2()
End Function
【マクロ（ワークシート）】
Private Sub Worksheet_Change(ByVal Target As Range)
If Not (Intersect(Target, Range("_入浴曜日")) Is Nothing) Then
' Debug.Print "Target.Address=" & Target.Address
Debug.Print "Target.Rows(1).Row=" & Target.Rows(1).Row
Debug.Print "Target.Rows(Target.Rows.Count).Row=" & Target.Rows(Target.Rows.Count).Row
' _入浴曜日のセル範囲で変化の発生した行だけ、条件付き書式を変更（体温）
Call mySSetFormatCondition1(Target.Rows(1).Row, Target.Rows(Target.Rows.Count).Row)
End If
If Not (Intersect(Target, Range("_StartYear1")) Is Nothing) Then
Call mySSetFormatCondition2 '条件付き書式を設定する（日付曜日）
' Debug.Print "mySSetFormatCondition2"
' Debug.Print "Target.Value=" & Target.Value
End If
If Not (Intersect(Target, Range("_StartMonth1")) Is Nothing) Then
Call mySSetFormatCondition2 '条件付き書式を設定する（日付曜日）
' Debug.Print "mySSetFormatCondition2"
' Debug.Print "Target.Value=" & Target.Value
End If
End Sub
ヤバイぜ！ ありがとうございます(^_0)ノ
by cheese999 (2022-02-11 08:51)