セル内改行で作成されたリストを、力業でテーブル化

先日他部署から、このようなリストが回ってきた。
実物は載せられないので、雰囲気だけ再現。
f:id:Infoment:20191215122931p:plain
なお詳細区分のセルは、一つのセル内で改行して記載されている。

これを更に別の表と突き合わせて、対照表を作成する必要がある。
とてもとても、遣り難い。

ということで、力業でテーブル化してみた。
f:id:Infoment:20191215121155p:plain

今回は最初、クラスモジュールを使おうかと思っていた。
しかし折角の機会なので、普段あまり使用しないTypeステートメントを使ってみることにした（その分だけ、ちょっと遠回り）。
docs.microsoft.com

Private Type 拳法
    拳区分 As String
    流派_大区分 As String
    流派_詳細区分 As String
    伝承者 As String
End Type

今回の作戦は、こうだ。

セル内改行で分割する。
各流派名と伝承者は、正規表現で抽出する。
結合セルの値は、MargeAreaプロパティで取得する。
取得した値で最終的に、配列を作成する。

実際のコードがこちら。

Private Function GetArray() As Variant
    ' 詳細区分が書かれた範囲。
    Dim TargetRange As Range
    Set TargetRange = Range("C2:C3")
    
    
    ' 詳細区分と伝承者を抽出するための正規表現。
    Dim myReg As Object
    Set myReg = CreateObject("VBScript.RegExp")
        myReg.Pattern = "^・(.+)（(.+)）"
    Dim MC As Object ' MatchCollection
    Dim SM As Object ' SubMatches
    
    ' 流派の数を数える。
    ' セル内改行（vbLf）で分割して、その要素数を数える。
    ' ※０番目から始まるので、要素数は＋１する必要あり。
    Dim jMax As Long
    Dim r As Range
        For Each r In TargetRange
            jMax = jMax + UBound(Split(r, vbLf)) + 1
        Next
    
    ' 各流派の情報をTypeステートメントで取得。
    Dim TempData() As 拳法
    ReDim TempData(1 To jMax)
    Dim i As Long
    Dim j As Long: j = 1
    Dim TempArray As Variant
        For Each r In TargetRange
            TempArray = Split(r, vbLf)
            For i = 0 To UBound(TempArray)
                If myReg.test(StrConv(TempArray(i), vbWide)) Then
                    Set MC = myReg.Execute(StrConv(TempArray(i), vbWide))
                    Set SM = MC(0).SubMatches
                    
                    With TempData(j)
                        ' セルが結合された範囲は、MergeAreaの一つ目の値を取得。
                        .拳区分 = r.Offset(, -2).MergeArea.Cells(1).Value
                        .流派_大区分 = r.Offset(, -1).MergeArea.Cells(1).Value
                        .流派_詳細区分 = SM(0)
                        .伝承者 = SM(1)
                    End With
                    
                    j = j + 1
                End If
            Next
        Next
        
    Dim arr() As Variant
    ReDim arr(0 To jMax, 1 To 4)
    
        ' ラベル作成。
        arr(0, 1) = "拳区分"
        arr(0, 2) = "流派（大区分）"
        arr(0, 3) = "詳細区分"
        arr(0, 4) = "伝承者"
    
        ' データセット。
        For j = 1 To jMax
            With TempData(j)
                arr(j, 1) = .拳区分
                arr(j, 2) = .流派_大区分
                arr(j, 3) = .流派_詳細区分
                arr(j, 4) = .伝承者
            End With
        Next
    
        GetArray = arr
End Function

それでは、テストしてみよう。

Sub test()
    Dim arr As Variant
        arr = GetArray
        
        Sheets.Add
        Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr
        Cells.EntireColumn.AutoFit
End Sub