年月週の表ラベルを作成する
昨日まで、指定した開始日から最終日までに含まれる週の数を知るために、クラスモジュールを作成していた。
infoment.hatenablog.com
目的は、↓ のような変換を行う必要に迫られたため。
そこで今日は、まず、年月週の表ラベルを作成することに挑戦する。
今回は、ラベル相当の配列を作成する関数を、昨日までのクラスモジュールに追加してみた。
クラスモジュール(DateObjectClass)
Public Function 配列_年月週(開始日 As Date, 最終日 As Date) As Variant ' 開始日と終了日から、その間が何週間あるかを求める。 Dim WeekCount As Long ' 引数Falseを指定することで、月を跨ぐ週の数を「2」でカウントしている。 WeekCount = 指定日間週数(開始日, 最終日, False) ' 週が連続するように、受け皿として配列を設ける。 Dim seq() As Variant ReDim seq(1 To 3, 1 To WeekCount) ' 各月が何週間あるかを、配列にセットする。 ' ※indexは、開始月数から始まっている。 ' 例えば開始日が3月の場合、LBound(NumberOfWeeksInEachMonth) = 3 となる。 Dim NumberOfWeeksInEachMonth As Variant NumberOfWeeksInEachMonth = 各月週数(開始日, 最終日) ' 配列に年月週を入れ込んでいく。 ' 12で割っているのは、開始日から最終日までに発生する年越しに対応するため。 Dim i As Long Dim j As Long Dim k As Long ' 小文字のエルが1やI(アイ)に見えるので、大文字で使用。 Dim L As Long: L = 1 For i = LBound(NumberOfWeeksInEachMonth) To UBound(NumberOfWeeksInEachMonth) ' 開始日月だけは、週が1から始まらない。 Select Case i Case LBound(NumberOfWeeksInEachMonth) k = 当月第何週(開始日) Case Else k = 1 End Select For j = k To k + NumberOfWeeksInEachMonth(i) - 1 If L = 1 Then seq(1, L) = Year(開始日) Else seq(1, L) = seq(1, 1) + _ WorksheetFunction.RoundDown((i - 1) / 12, 0) End If seq(2, L) = (i - 1) Mod 12 + 1 seq(3, L) = j L = L + 1 Next Next 配列_年月週 = seq End Function
標準モジュール
試しにこれを、シートに貼り付けてみる。
Sub Test() Dim DObj As DateObjectClass Set DObj = New DateObjectClass Dim seq As Variant seq = DObj.配列_年月週(開始日:="2019/3/19", 最終日:="2019/5/10") With Range("A1").Resize(3, UBound(seq, 2)) .Value = seq .Rows(1).NumberFormatLocal = "0000年" .Rows(2).NumberFormatLocal = "0月" .Rows(3).NumberFormatLocal = "第0週" End With End Sub
↓ 結果がこちら。
取り敢えず、まずまずといったところか。
明日に続きます。
参考まで。