作成した年月週の表ラベルに実際の値を充て込んでみる ①

昨日は、開始日と最終日を指定しただけで、年月週の表ラベルを作成してみた。
infoment.hatenablog.com
今回はいよいよ、以下の目標に挑戦する。
目標：作成した年月週の表ラベルに、実際の値を充て込んでみる。

それでは、まず元の表について、今一度眺めてみる。

表の作りとしては、非常によろしくない。共通部分が空白だったり、数字と文字が混在していたり。この表は、できればこんな形の方が扱いやすい。

そのように加工すること自体も面倒だが、元の表がそうなのだから仕方ない。

ということでまず、数値と文字が入り混じった中から、数字だけを取り出す関数を作成する。先頭が数字であれば、↓こんな方法がある。

しかし今回は「第〇週」のように、先頭が文字のケースが含まれている。

そこで今回は、安易に「正規表現」を使うことにした。

' 正の整数のみ抽出可。

Function ExtractNumbers(original_character As String) As Long
    ' Microsoft VBScript Regular Expression 5.5 参照済み。
    Dim myReg As RegExp
    Set myReg = New RegExp
        ' １文字以上連続する数字が、０文字以上連続する
        ' 数字以外の文字に挟まれている。
        myReg.Pattern = "^\D*(\d+)\D*"
    Dim mc As MatchCollection
    Dim sb As SubMatches
    
        If myReg.Test(original_character) Then
            Set mc = myReg.Execute(original_character)
            Set sb = mc(0).SubMatches
            ExtractNumbers = sb(0)
        Else
            ' 数字が含まれない場合は、-1を返す。
            ' ※文字列に-1が含まれる場合、戻り値は「1」。
            ExtractNumbers = -1
        End If
End Function

表の編集は今回、一旦配列に取り込んで、全て配列内で処理する。

Function EditedTable(table_range As Range) As Variant
    Dim seq As Variant
        seq = table_range
    
    ' 最初の三行について、値を全て数字のみにする。
    Dim r As Long
    Dim c As Long
    Dim str As String
        For r = 1 To 3
            For c = 2 To UBound(seq, 2)
                str = seq(r, c)
                If str <> vbNullString Then
                    seq(r, c) = ExtractNumbers(str)
                End If
            Next
        Next
        
    ' 三行目の値を基準に、空欄を埋めていく。
        For c = 3 To UBound(seq, 2)
            
            ' 一つ上のセルが空欄の場合、左斜め上の値を充てる。
            If seq(2, c) = vbNullString Then
                seq(2, c) = seq(2, c - 1)
            End If
            
            ' 二つ上のセルが空欄の場合
            If seq(1, c) = vbNullString Then
                ' 今月が先月より小さい場合は、年を一つ加える。
                ' ※１２月も翌１月も表に無い場合を想定。
                If seq(2, c) < seq(2, c - 1) Then
                    seq(1, c) = seq(1, c - 1) + 1
                Else
                    seq(1, c) = seq(1, c - 1)
                End If
            End If
        Next
        
        EditedTable = seq
End Function

早速テストしてみる。

Sub testoooooooooooo()
    Dim seq As Variant
        seq = EditedTable(Range("B1").CurrentRegion)
    
        Range("A11").Resize(UBound(seq), UBound(seq, 2)) = seq
End Sub

どうやら、思ったとおりに動いてくれたようだ。
と、ここで時間切れ。明日に続きます。

参考まで。