エクセル小僧：VBAで数式を設定（改） [コンピューター]
【前記事】
エクセル小僧：VBAで数式を設定
https://cheese999.blog.ss-blog.jp/2021-12-20
で紹介した、エクセルで作成した勤務表において、各人が何の勤務（早番、遅番、夜勤）に何日ずつ割当たっているか計算する
数式をVBAで設定するマクロを変更しました。
【変更点】
・初期設定値をなるべく減らす様に変更。
・日付ごとに各勤務が何人ずつ存在するか集計する数式を設定するマクロ（数式編集2）を追加
【マクロ】
Sub 数式編集1()
'【機能】名前ごと、勤務ごと（A1, C1, C2, 夜勤、休）の集計
'【変数】
Dim i As Long ' 整数
Dim Name1 As String ' 名前
Dim mySheetName1 As String ' シート名
Dim tmpString1 As String ' 文字列
Dim tmpString2 As Variant ' 文字列
Dim ColName1 As Integer ' 名前の列(F列)の列番号=6
Dim Start_Row1 As Integer ' 開始行の行番号
Dim End_Row1 As Integer ' 最終行の行番号
Dim Start_Day1 As Variant ' 開始日を表す文字列
Dim RangeName_Block1() As Variant ' 各ブロックのRange名（開始日無し）
Dim RangeName_Block2() As Variant ' 各ブロックのRange名（開始日有り）
Dim Rows_Block1(), Rows_Block2() As Variant ' 各ブロックの開始行、終了行
Dim myCount2() As Variant ' 各ブロックの開始行、終了行の内側の各配列の添え字
Dim myMaxCount2() As Variant ' 各ブロックの開始行、終了行の配列の各次元の添え字の最大値
Dim Col_Days1() As Variant ' 今月16日、来月15日の列番号
Dim Col_Sum1() As Variant ' 集計列の列名（開始列、最終列）
Dim Col_Sum2() As Variant ' 集計列の列名（全列）
Dim RangeName1_勤務() As Variant ' 集計列の勤務名
'【実行コード】
mySheetName1 = ActiveSheet.Name ' アクティブシート名
' Debug.Print "mySheetName1=" & mySheetName1
ColName1 = Range("F:F").Column ' 名前の列(F列)の列番号=6
' Debug.Print "ColName1=" & ColName1
Start_Row1 = 8 ' 開始行の行番号
End_Row1 = 81 ' 最終行の行番号
Rows_Block1 = Array(Array(8, 9), Array(10, 24), Array(25, 39), Array(40, 55), _
Array(56, 71), Array(72, 74), Array(75, 78), Array(79, 81)) ' 各ブロックの開始行、終了行
Start_Day1 = "_2021_1216" ' 開始日を表す文字列
RangeName_Block1 = Array("_top", "_2東", "_2西", "_3東", _
"_3西", "_ヘルプ", "_CM", "_応援") ' 各ブロックのRange名（開始日無し）
Col_Days1 = Array(Range("M:M").Column, Range("AQ:AQ").Column) ' 今月16日、来月15日の列番号
Col_Sum1 = Array("AS", "AY") ' 集計列の列名（開始列、最終列）
RangeName1_勤務 = Array("_A1", "_C1", "_C2", "_夜勤", "_休") ' 集計列の勤務名
' 入れ子になっている1次元配列から2次元配列への変換
Rows_Block2() = myTransArray1(Rows_Block1(), myCount2(), myMaxCount2()) ' 各ブロックの開始行、終了行
' Debug.Print "myCount2(0) = " & myCount2(0)
' Debug.Print "myMaxCount2(0) = " & myMaxCount2(0)
' Debug.Print "myMaxCount2(1) = " & myMaxCount2(1)
' Debug.Print "Rows_Block2(2, 0)=" & Rows_Block2(2, 0)
ReDim RangeName_Block2(UBound(RangeName_Block1, 1)) ' 配列をReDim
i = 0
For Each tmpString2 In RangeName_Block1
RangeName_Block2(i) = RangeName_Block1(i) & Start_Day1 ' 各ブロックのRange名（開始日有り）に変更
' Debug.Print "RangeName_Block2(" & i & ")=" & RangeName_Block2(i)
Range(ColNum2Let(Col_Days1(0)) & Rows_Block2(i, 0) & ":" & ColNum2Let(Col_Days1(1)) & Rows_Block2(i, 1)).Name _
= RangeName_Block2(i) ' 各ブロックの今月16日から来月15日までのセル範囲に名前付け
i = i + 1
Next tmpString2
' RangeName_Block1 = Array("_top_2021_1216", "_2東_2021_1216", "_2西_2021_1216", "_3東_2021_1216", _
' "_3西_2021_1216", "_ヘルプ_2021_1216", "_CM_2021_1216", "_応援_2021_1216") ' 各ブロックのRange名
ReDim Col_Sum2(Range(Col_Sum1(0) & ":" & Col_Sum1(1)).Columns.Count - 1) ' 配列をReDim
For i = 0 To UBound(Col_Sum2, 1)
Col_Sum2(i) = ColNum2Let(Range(Col_Sum1(0) & ":" & Col_Sum1(0)).Column + i) ' 集計列の列名（全列）
' Debug.Print "Col_Sum2(" & i & ")=" & Col_Sum2(i)
Next i
For i = Start_Row1 To End_Row1
Name1 = Cells(i, ColName1).Value
Name1 = myFDelKakko1(Name1) ' ★、空白（半角、全角）、カッコ（半角、全角）を消す
' Name1 = Replace(Name1, "★", "") ' ★を消す
' Name1 = Replace(Name1, " ", "") ' 半角空白を消す
' Name1 = Replace(Name1, " ", "") ' 全角空白を消す
' Name1 = Replace(Name1, "(", "") ' 半角左カッコを消す
' Name1 = Replace(Name1, ")", "") ' 半角右カッコを消す
' Name1 = Replace(Name1, "（", "") ' 全角左カッコを消す
' Name1 = Replace(Name1, "）", "") ' 全角右カッコを消す
Select Case i
Case Start_Row1 To Range(RangeName_Block2(0)).Item(Range(RangeName_Block2(0)).Count).Row
Name1 = Name1 & RangeName_Block1(0) ' ブロック名（_top）を追加
Case Range(RangeName_Block2(1)).Item(1).Row To Range(RangeName_Block2(1)).Item(Range(RangeName_Block2(1)).Count).Row
Name1 = Name1 & RangeName_Block1(1) ' ブロック名（_2東）を追加
Case Range(RangeName_Block2(2)).Item(1).Row To Range(RangeName_Block2(2)).Item(Range(RangeName_Block2(2)).Count).Row
Name1 = Name1 & RangeName_Block1(2) ' ブロック名（_2西）を追加
Case Range(RangeName_Block2(3)).Item(1).Row To Range(RangeName_Block2(3)).Item(Range(RangeName_Block2(3)).Count).Row
Name1 = Name1 & RangeName_Block1(3) ' ブロック名（_3東）を追加
Case Range(RangeName_Block2(4)).Item(1).Row To Range(RangeName_Block2(4)).Item(Range(RangeName_Block2(4)).Count).Row
Name1 = Name1 & RangeName_Block1(4) ' ブロック名（_3西）を追加
Case Range(RangeName_Block2(5)).Item(1).Row To Range(RangeName_Block2(5)).Item(Range(RangeName_Block2(5)).Count).Row
Name1 = Name1 & RangeName_Block1(5) ' ブロック名（_ヘルプ）を追加
Case Range(RangeName_Block2(6)).Item(1).Row To Range(RangeName_Block2(6)).Item(Range(RangeName_Block2(6)).Count).Row
Name1 = Name1 & RangeName_Block1(6) ' ブロック名（_CM）を追加
Case Range(RangeName_Block2(7)).Item(1).Row To End_Row1
Name1 = Name1 & RangeName_Block1(7) ' ブロック名（_応援）を追加
End Select
Name1 = Name1 & Start_Day1 ' 開始日を追加
' Debug.Print "名前=" & Name1
tmpString1 = "='" & mySheetName1 & "'!R" & i & "C" & Col_Days1(0) & ":R" & i & "C" & Col_Days1(1)
' Debug.Print "tmpString1=" & tmpString1
ActiveWorkbook.Names.Add Name:=Name1, RefersToR1C1:=tmpString1 ' 今月16日から来月15日までのセル範囲に名前を追加
Range(Col_Sum2(0) & i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName1_勤務(0) & "))*1)" ' A1の数式
Range(Col_Sum2(1) & i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName1_勤務(1) & "))*1)" ' C1の数式
Range(Col_Sum2(2) & i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName1_勤務(2) & "))*1)" ' C2の数式
Range(Col_Sum2(3) & i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName1_勤務(3) & "))*1)" ' 夜勤の数式
Range(Col_Sum2(4) & i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName1_勤務(4) & "))*1)" ' 休の数式
Range(Col_Sum2(5) & i).Formula = "=COUNTA(" & Name1 & ")-SUM(" & Col_Sum2(0) & i & ":" & Col_Sum2(4) & i & ")" ' 他の数式
Range(Col_Sum2(6) & i).Formula = "=SUM(" & Col_Sum2(0) & i & ":" & Col_Sum2(5) & i & ")" ' 計の数式
Next i
End Sub
Sub 数式編集2()
' 日付ごと、勤務ごと（A1, C1, C2, 夜勤、休）の集計
'【変数】
Dim i1 As Integer
Dim Name1 As String ' 名前
Dim mySheetName1 As String ' シート名
Dim Start_Day1 As String ' 開始日を表す文字列
Dim tmpString2 As String ' 文字列
Dim StartCol1 As Integer ' 開始列（開始月の16日）
Dim EndCol1 As Integer ' 最終列（翌月の15日）
Dim StartRow1 As Integer ' 開始行
Dim EndRow1 As Integer ' 最終行
Dim Row_Sum1(), Row_Sum2() As Variant ' 集計列の行番号
Dim RangeName2_勤務() As Variant ' 集計行の勤務名
'【実行コード】
StartCol1 = Range("M:M").Column ' 開始列（開始月の16日）
EndCol1 = Range("AQ:AQ").Column ' 最終列（翌月の15日）
StartRow1 = 8 ' 開始行
EndRow1 = 81 ' 最終行
mySheetName1 = ActiveSheet.Name ' アクティブシート名
' Debug.Print "mySheetName1=" & mySheetName1
Start_Day1 = "_2021_1216" ' 開始日を表す文字列
Row_Sum1 = Array(149, 155) ' 集計行の行番号（開始行、最終行）
RangeName2_勤務 = Array("_A1_2", "_C1_2", "_C2_2", "_夜勤_2", "_休_2") ' 集計列の勤務名
ReDim Row_Sum2(Range(Row_Sum1(0) & ":" & Row_Sum1(1)).Rows.Count - 1) ' 配列をReDim
For i = 0 To UBound(Row_Sum2, 1)
Row_Sum2(i) = Row_Sum1(0) + i ' 集計行の行番号（全行）
Next i
For i = StartCol1 To EndCol1
Name1 = "Col" & i & Start_Day1
tmpString2 = "='" & mySheetName1 & "'!R" & StartRow1 & "C" & i & ":R" & EndRow1 & "C" & i
ActiveWorkbook.Names.Add Name:=Name1, RefersToR1C1:=tmpString2 ' 1日分のセル範囲に名前を追加
Cells(Row_Sum2(0), i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName2_勤務(0) & "))*1)" ' A1の数式
Cells(Row_Sum2(1), i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName2_勤務(1) & "))*1)" ' C1の数式
Cells(Row_Sum2(2), i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName2_勤務(2) & "))*1)" ' C2の数式
Cells(Row_Sum2(3), i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName2_勤務(3) & "))*1)" ' 夜勤の数式
Cells(Row_Sum2(4), i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName2_勤務(4) & "))*1)" ' 休の数式
Cells(Row_Sum2(5), i).Formula = "=COUNTA(" & Name1 & ")-SUM(" & ColNum2Let(i) & Row_Sum2(0) _
& ":" & ColNum2Let(i) & Row_Sum2(4) & ")" ' 他の数式
Cells(Row_Sum2(6), i).Formula = "=SUM(" & ColNum2Let(i) & Row_Sum2(0) & ":" _
& ColNum2Let(i) & Row_Sum2(5) & ")" ' 計の数式
Next i
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 myFDelKakko1(ByVal myString1 As String) As String
'【機能】文字列からカッコや空白を消去
'【引数】
' myString1 : 元の文字列
'【変数】
Dim myDelChar1() As Variant ' 消去する文字
Dim myString2, tmpString3 As Variant ' 文字列
'【実行コード】
myDelChar1 = Array("★", " ", " ", "(", ")", "（", "）")
myString2 = myString1
For Each tmpString3 In myDelChar1
myString2 = Replace(myString2, tmpString3, "") ' tmpString3をmyString2から消す
Next tmpString3
myFDelKakko1 = CStr(myString2)
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
エクセル小僧：VBAで数式を設定
https://cheese999.blog.ss-blog.jp/2021-12-20
で紹介した、エクセルで作成した勤務表において、各人が何の勤務（早番、遅番、夜勤）に何日ずつ割当たっているか計算する
数式をVBAで設定するマクロを変更しました。
【変更点】
・初期設定値をなるべく減らす様に変更。
・日付ごとに各勤務が何人ずつ存在するか集計する数式を設定するマクロ（数式編集2）を追加
【マクロ】
Sub 数式編集1()
'【機能】名前ごと、勤務ごと（A1, C1, C2, 夜勤、休）の集計
'【変数】
Dim i As Long ' 整数
Dim Name1 As String ' 名前
Dim mySheetName1 As String ' シート名
Dim tmpString1 As String ' 文字列
Dim tmpString2 As Variant ' 文字列
Dim ColName1 As Integer ' 名前の列(F列)の列番号=6
Dim Start_Row1 As Integer ' 開始行の行番号
Dim End_Row1 As Integer ' 最終行の行番号
Dim Start_Day1 As Variant ' 開始日を表す文字列
Dim RangeName_Block1() As Variant ' 各ブロックのRange名（開始日無し）
Dim RangeName_Block2() As Variant ' 各ブロックのRange名（開始日有り）
Dim Rows_Block1(), Rows_Block2() As Variant ' 各ブロックの開始行、終了行
Dim myCount2() As Variant ' 各ブロックの開始行、終了行の内側の各配列の添え字
Dim myMaxCount2() As Variant ' 各ブロックの開始行、終了行の配列の各次元の添え字の最大値
Dim Col_Days1() As Variant ' 今月16日、来月15日の列番号
Dim Col_Sum1() As Variant ' 集計列の列名（開始列、最終列）
Dim Col_Sum2() As Variant ' 集計列の列名（全列）
Dim RangeName1_勤務() As Variant ' 集計列の勤務名
'【実行コード】
mySheetName1 = ActiveSheet.Name ' アクティブシート名
' Debug.Print "mySheetName1=" & mySheetName1
ColName1 = Range("F:F").Column ' 名前の列(F列)の列番号=6
' Debug.Print "ColName1=" & ColName1
Start_Row1 = 8 ' 開始行の行番号
End_Row1 = 81 ' 最終行の行番号
Rows_Block1 = Array(Array(8, 9), Array(10, 24), Array(25, 39), Array(40, 55), _
Array(56, 71), Array(72, 74), Array(75, 78), Array(79, 81)) ' 各ブロックの開始行、終了行
Start_Day1 = "_2021_1216" ' 開始日を表す文字列
RangeName_Block1 = Array("_top", "_2東", "_2西", "_3東", _
"_3西", "_ヘルプ", "_CM", "_応援") ' 各ブロックのRange名（開始日無し）
Col_Days1 = Array(Range("M:M").Column, Range("AQ:AQ").Column) ' 今月16日、来月15日の列番号
Col_Sum1 = Array("AS", "AY") ' 集計列の列名（開始列、最終列）
RangeName1_勤務 = Array("_A1", "_C1", "_C2", "_夜勤", "_休") ' 集計列の勤務名
' 入れ子になっている1次元配列から2次元配列への変換
Rows_Block2() = myTransArray1(Rows_Block1(), myCount2(), myMaxCount2()) ' 各ブロックの開始行、終了行
' Debug.Print "myCount2(0) = " & myCount2(0)
' Debug.Print "myMaxCount2(0) = " & myMaxCount2(0)
' Debug.Print "myMaxCount2(1) = " & myMaxCount2(1)
' Debug.Print "Rows_Block2(2, 0)=" & Rows_Block2(2, 0)
ReDim RangeName_Block2(UBound(RangeName_Block1, 1)) ' 配列をReDim
i = 0
For Each tmpString2 In RangeName_Block1
RangeName_Block2(i) = RangeName_Block1(i) & Start_Day1 ' 各ブロックのRange名（開始日有り）に変更
' Debug.Print "RangeName_Block2(" & i & ")=" & RangeName_Block2(i)
Range(ColNum2Let(Col_Days1(0)) & Rows_Block2(i, 0) & ":" & ColNum2Let(Col_Days1(1)) & Rows_Block2(i, 1)).Name _
= RangeName_Block2(i) ' 各ブロックの今月16日から来月15日までのセル範囲に名前付け
i = i + 1
Next tmpString2
' RangeName_Block1 = Array("_top_2021_1216", "_2東_2021_1216", "_2西_2021_1216", "_3東_2021_1216", _
' "_3西_2021_1216", "_ヘルプ_2021_1216", "_CM_2021_1216", "_応援_2021_1216") ' 各ブロックのRange名
ReDim Col_Sum2(Range(Col_Sum1(0) & ":" & Col_Sum1(1)).Columns.Count - 1) ' 配列をReDim
For i = 0 To UBound(Col_Sum2, 1)
Col_Sum2(i) = ColNum2Let(Range(Col_Sum1(0) & ":" & Col_Sum1(0)).Column + i) ' 集計列の列名（全列）
' Debug.Print "Col_Sum2(" & i & ")=" & Col_Sum2(i)
Next i
For i = Start_Row1 To End_Row1
Name1 = Cells(i, ColName1).Value
Name1 = myFDelKakko1(Name1) ' ★、空白（半角、全角）、カッコ（半角、全角）を消す
' Name1 = Replace(Name1, "★", "") ' ★を消す
' Name1 = Replace(Name1, " ", "") ' 半角空白を消す
' Name1 = Replace(Name1, " ", "") ' 全角空白を消す
' Name1 = Replace(Name1, "(", "") ' 半角左カッコを消す
' Name1 = Replace(Name1, ")", "") ' 半角右カッコを消す
' Name1 = Replace(Name1, "（", "") ' 全角左カッコを消す
' Name1 = Replace(Name1, "）", "") ' 全角右カッコを消す
Select Case i
Case Start_Row1 To Range(RangeName_Block2(0)).Item(Range(RangeName_Block2(0)).Count).Row
Name1 = Name1 & RangeName_Block1(0) ' ブロック名（_top）を追加
Case Range(RangeName_Block2(1)).Item(1).Row To Range(RangeName_Block2(1)).Item(Range(RangeName_Block2(1)).Count).Row
Name1 = Name1 & RangeName_Block1(1) ' ブロック名（_2東）を追加
Case Range(RangeName_Block2(2)).Item(1).Row To Range(RangeName_Block2(2)).Item(Range(RangeName_Block2(2)).Count).Row
Name1 = Name1 & RangeName_Block1(2) ' ブロック名（_2西）を追加
Case Range(RangeName_Block2(3)).Item(1).Row To Range(RangeName_Block2(3)).Item(Range(RangeName_Block2(3)).Count).Row
Name1 = Name1 & RangeName_Block1(3) ' ブロック名（_3東）を追加
Case Range(RangeName_Block2(4)).Item(1).Row To Range(RangeName_Block2(4)).Item(Range(RangeName_Block2(4)).Count).Row
Name1 = Name1 & RangeName_Block1(4) ' ブロック名（_3西）を追加
Case Range(RangeName_Block2(5)).Item(1).Row To Range(RangeName_Block2(5)).Item(Range(RangeName_Block2(5)).Count).Row
Name1 = Name1 & RangeName_Block1(5) ' ブロック名（_ヘルプ）を追加
Case Range(RangeName_Block2(6)).Item(1).Row To Range(RangeName_Block2(6)).Item(Range(RangeName_Block2(6)).Count).Row
Name1 = Name1 & RangeName_Block1(6) ' ブロック名（_CM）を追加
Case Range(RangeName_Block2(7)).Item(1).Row To End_Row1
Name1 = Name1 & RangeName_Block1(7) ' ブロック名（_応援）を追加
End Select
Name1 = Name1 & Start_Day1 ' 開始日を追加
' Debug.Print "名前=" & Name1
tmpString1 = "='" & mySheetName1 & "'!R" & i & "C" & Col_Days1(0) & ":R" & i & "C" & Col_Days1(1)
' Debug.Print "tmpString1=" & tmpString1
ActiveWorkbook.Names.Add Name:=Name1, RefersToR1C1:=tmpString1 ' 今月16日から来月15日までのセル範囲に名前を追加
Range(Col_Sum2(0) & i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName1_勤務(0) & "))*1)" ' A1の数式
Range(Col_Sum2(1) & i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName1_勤務(1) & "))*1)" ' C1の数式
Range(Col_Sum2(2) & i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName1_勤務(2) & "))*1)" ' C2の数式
Range(Col_Sum2(3) & i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName1_勤務(3) & "))*1)" ' 夜勤の数式
Range(Col_Sum2(4) & i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName1_勤務(4) & "))*1)" ' 休の数式
Range(Col_Sum2(5) & i).Formula = "=COUNTA(" & Name1 & ")-SUM(" & Col_Sum2(0) & i & ":" & Col_Sum2(4) & i & ")" ' 他の数式
Range(Col_Sum2(6) & i).Formula = "=SUM(" & Col_Sum2(0) & i & ":" & Col_Sum2(5) & i & ")" ' 計の数式
Next i
End Sub
Sub 数式編集2()
' 日付ごと、勤務ごと（A1, C1, C2, 夜勤、休）の集計
'【変数】
Dim i1 As Integer
Dim Name1 As String ' 名前
Dim mySheetName1 As String ' シート名
Dim Start_Day1 As String ' 開始日を表す文字列
Dim tmpString2 As String ' 文字列
Dim StartCol1 As Integer ' 開始列（開始月の16日）
Dim EndCol1 As Integer ' 最終列（翌月の15日）
Dim StartRow1 As Integer ' 開始行
Dim EndRow1 As Integer ' 最終行
Dim Row_Sum1(), Row_Sum2() As Variant ' 集計列の行番号
Dim RangeName2_勤務() As Variant ' 集計行の勤務名
'【実行コード】
StartCol1 = Range("M:M").Column ' 開始列（開始月の16日）
EndCol1 = Range("AQ:AQ").Column ' 最終列（翌月の15日）
StartRow1 = 8 ' 開始行
EndRow1 = 81 ' 最終行
mySheetName1 = ActiveSheet.Name ' アクティブシート名
' Debug.Print "mySheetName1=" & mySheetName1
Start_Day1 = "_2021_1216" ' 開始日を表す文字列
Row_Sum1 = Array(149, 155) ' 集計行の行番号（開始行、最終行）
RangeName2_勤務 = Array("_A1_2", "_C1_2", "_C2_2", "_夜勤_2", "_休_2") ' 集計列の勤務名
ReDim Row_Sum2(Range(Row_Sum1(0) & ":" & Row_Sum1(1)).Rows.Count - 1) ' 配列をReDim
For i = 0 To UBound(Row_Sum2, 1)
Row_Sum2(i) = Row_Sum1(0) + i ' 集計行の行番号（全行）
Next i
For i = StartCol1 To EndCol1
Name1 = "Col" & i & Start_Day1
tmpString2 = "='" & mySheetName1 & "'!R" & StartRow1 & "C" & i & ":R" & EndRow1 & "C" & i
ActiveWorkbook.Names.Add Name:=Name1, RefersToR1C1:=tmpString2 ' 1日分のセル範囲に名前を追加
Cells(Row_Sum2(0), i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName2_勤務(0) & "))*1)" ' A1の数式
Cells(Row_Sum2(1), i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName2_勤務(1) & "))*1)" ' C1の数式
Cells(Row_Sum2(2), i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName2_勤務(2) & "))*1)" ' C2の数式
Cells(Row_Sum2(3), i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName2_勤務(3) & "))*1)" ' 夜勤の数式
Cells(Row_Sum2(4), i).Formula = "=SUMPRODUCT((ASC(" & Name1 & ")=ASC(" & RangeName2_勤務(4) & "))*1)" ' 休の数式
Cells(Row_Sum2(5), i).Formula = "=COUNTA(" & Name1 & ")-SUM(" & ColNum2Let(i) & Row_Sum2(0) _
& ":" & ColNum2Let(i) & Row_Sum2(4) & ")" ' 他の数式
Cells(Row_Sum2(6), i).Formula = "=SUM(" & ColNum2Let(i) & Row_Sum2(0) & ":" _
& ColNum2Let(i) & Row_Sum2(5) & ")" ' 計の数式
Next i
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 myFDelKakko1(ByVal myString1 As String) As String
'【機能】文字列からカッコや空白を消去
'【引数】
' myString1 : 元の文字列
'【変数】
Dim myDelChar1() As Variant ' 消去する文字
Dim myString2, tmpString3 As Variant ' 文字列
'【実行コード】
myDelChar1 = Array("★", " ", " ", "(", ")", "（", "）")
myString2 = myString1
For Each tmpString3 In myDelChar1
myString2 = Replace(myString2, tmpString3, "") ' tmpString3をmyString2から消す
Next tmpString3
myFDelKakko1 = CStr(myString2)
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
ヤバイぜ！ ありがとうございます(^_0)ノ
by cheese999 (2022-01-11 07:41)
ColNum2Let関数に説明を入れました。(^^♪
by cheese999 (2022-01-15 07:10)