構成展開で解くのでしょうか1

Question

お世話になります．

Windows7 (64bit) EXCEL 2010 (64bit) VBAで上記の点について困っています．

http://www.mext.go.jp/b_menu/shingi/gijyutu/gijyutu3/houkoku/1298713.htm

上記のサイトにあるPDFからテキスト情報を抽出しております．

http://www.mext.go.jp/component/b_menu/shingi/toushin/__icsFiles/afieldfile/2011/01/25/1299012_1.pdf

から

http://www.mext.go.jp/component/b_menu/shingi/toushin/__icsFiles/afieldfile/2011/01/25/1299012_18.pdf

まで

データ構造は

http://www.mext.go.jp/component/b_menu/shingi/toushin/__icsFiles/afieldfile/2011/06/01/1299011_1.pdf

の5ページに有るように，食品群，区分，大分類，中分類，小分類，細目の6階層の木構造となっています．

ですが各階層に必ずノードがあるわけではなく，省略されているノードがかなりあります．

木構造を取得するには構成展開という手法があると分かりましたが，具体的にどうするかがわかりません．

自分で書いたコードでは途中のノードからしか取得できていません．

http://fujiitoshiki.com/wordpress/?p=26

VBAを使用するまでの手順は上記ページにありますが，要はコピペです．

最終的に欲しい形は

A列　Item_Number

B列　"食品群"

C列　"大分類"

D列　"中分類"

E列　"小分類"

F列　"細目"

となります．ただ，どうしても空欄ができてしまう箇所があるため，現状では

A列　Item_Number

B列　"食品群"

C列　"大分類"&"中分類"&"小分類"&"細目"

の形を取っています．Item_Numberは５桁の数値，食品群はItem_Numberの上２桁です．

よろしくお願い致します．

Option Explicit
Sub ItemNum() 
Dim mySht           As Worksheet
Dim myRng           As Range
Dim i               As Long
Dim j               As Long
Dim k               As Long
Dim tmpAr           As Variant
Dim myItem()        As String
Dim myNum1()        As String
Dim myNum2()        As String
Dim ItemNumAr()     As String
Dim myCancel()      As String
Dim Cancel_Ar()     As String
Dim myAr()          As String
Dim myGroupNamJP()  As String
Dim myGroupNumJP()  As String
Dim myGroupNamEN()  As String
Dim myGroupNumEN()  As String
Dim GroupAr()       As String
Dim myRegExp1       As Object
Dim myRegExp2       As Object
Dim myStrPtn        As String
Dim myStrPtn2       As String
Const startStrPtn   As String = "^(1\)|residues)$"
Dim tmpStr          As String
Const endStrPtn     As String = "[0-9]\)$"
Const JapStrPtn     As String = "([ぁ-ヶ]|[亜-黑])+$"   'http://homepage2.nifty.com/zaco/rexp/rexp06.html#2
Dim myStr           As String
Set mySht = ActiveSheet
Set myRng = Application.Intersect(mySht.Range("A:F"), mySht.UsedRange)
tmpAr = myRng
Set myRegExp1 = CreateObject("VBScript.RegExp")
myStrPtn = "^[0-9]{5}$"
With myRegExp1
    .Pattern = myStrPtn
    .IgnoreCase = True
    .Global = True
End With
Set myRegExp2 = CreateObject("VBScript.RegExp")
With myRegExp2
    .Pattern = startStrPtn
    .IgnoreCase = True
    .Global = True
End With
'Item_Numberと行番号の抽出
j = 0
For i = LBound(tmpAr) To UBound(tmpAr)
    If myRegExp1.Test(tmpAr(i, 1)) And _
       tmpAr(i, 2) <> "（欠番）" Then
        ReDim Preserve myItem(j)
        ReDim Preserve myNum1(j)
        myItem(j) = tmpAr(i, 1)
        myNum1(j) = i
    Else
        j = j - 1
    End If
    j = j + 1
Next i
'ItemNumAr(k, 1) = myNum1(k - 1) + 1はItem_Number直下の英語名を取得するのを防ぐためです．
ReDim ItemNumAr(j - 1, 2)
    ItemNumAr(LBound(ItemNumAr), 0) = myItem(LBound(ItemNumAr))
    ItemNumAr(LBound(ItemNumAr), 1) = 7
    ItemNumAr(LBound(ItemNumAr), 2) = myNum1(LBound(ItemNumAr))
For k = LBound(ItemNumAr) + 1 To UBound(ItemNumAr)
    ItemNumAr(k, 0) = myItem(k)
    ItemNumAr(k, 1) = myNum1(k - 1) + 1
    ItemNumAr(k, 2) = myNum1(k)
Next k
Erase myItem
Erase myNum1
'ここまででItemNumArにItem_Numberと行番号，前レコードの行番号を取得しました．
'1)とresiduesの間を除去します．
j = 0
For i = LBound(tmpAr) To UBound(tmpAr)
    If myRegExp2.Test(tmpAr(i, 1)) _
    Then
        ReDim Preserve myItem(j)
        ReDim Preserve myNum1(i)
        myItem(j) = tmpAr(i, 1)
        myNum1(j) = i
    Else
        j = j - 1
    End If
    j = j + 1
Next i
'前処理．ここから除去範囲の開始行番号と終了行番号を取得します．
ReDim myCancel(UBound(myItem), 1)
For k = LBound(myCancel) To UBound(myCancel)
    myCancel(k, 0) = myItem(k)
    myCancel(k, 1) = myNum1(k)
Next k
Erase myItem
Erase myNum1
'ここから中間のresiduesを除去する処理です．
ReDim Preserve myCancel(UBound(myCancel), 2)
j = 0
For i = LBound(myCancel) To UBound(myCancel) - 1
    If myCancel(i, 0) = "1)" Then
        If myCancel(i + 2, 0) = "residues" Then
            myCancel(i, 2) = myCancel(i + 2, 1)
        Else
            myCancel(i, 2) = myCancel(i + 1, 1)
        End If
    Else
        j = j - 1
    End If
    j = j + 1
Next i
'除去する行番号の先頭と最後との集合を取得します．
'重要なのはCancel_Ar(j, 1)とCancel_Ar(j, 2)のみです．
ReDim Cancel_Ar(j - 1, 2)
j = 0
For i = LBound(myCancel) To UBound(myCancel) - 1
    If myCancel(i, 0) = "1)" Then
        Cancel_Ar(j, 0) = myCancel(i, 0)    '1)の文字列
        Cancel_Ar(j, 1) = myCancel(i, 1)    '1)のある行番号（先頭行）
        Cancel_Ar(j, 2) = myCancel(i, 2)    'residuesのある行番号（最終行）
    Else
        j = j - 1
    End If
    j = j + 1
Next i
'ここまでで除去する行番号の集合をCancel_Arに取得しました．
'Cancel_ArとItemNumArとを掛けあわせてItemNumArにレコードを挿入します．
'ただし，レコードを挿入しても検索すべき行がない場合は挿入しません．
k = 0
ReDim myItem(k)
ReDim myNum1(k)
ReDim myNum2(k)
For i = LBound(ItemNumAr) To UBound(ItemNumAr)
    ReDim Preserve myItem(k)
    ReDim Preserve myNum1(k)
    ReDim Preserve myNum2(k)
    For j = LBound(Cancel_Ar) To UBound(Cancel_Ar)
        If CLng(ItemNumAr(i, 1)) < CLng(Cancel_Ar(j, 1)) And _
                                   CLng(Cancel_Ar(j, 1)) < CLng(ItemNumAr(i, 2)) And _
           CLng(ItemNumAr(i, 1)) < CLng(Cancel_Ar(j, 2)) And _
                                   CLng(Cancel_Ar(j, 2)) < CLng(ItemNumAr(i, 2)) _
        Then
            If Cancel_Ar(j, 1) - ItemNumAr(i, 1) < 3 Then
                myItem(k) = ItemNumAr(i, 0)
                myNum1(k) = Cancel_Ar(j, 2)
                myNum2(k) = ItemNumAr(i, 2)
            Else
                myNum2(k) = Cancel_Ar(j, 1)
                k = k + 1
                ReDim Preserve myItem(k)
                ReDim Preserve myNum1(k)
                ReDim Preserve myNum2(k)
                myItem(k) = ItemNumAr(i, 0)
                myNum1(k) = Cancel_Ar(j, 2)
                myNum2(k) = ItemNumAr(i, 2)
            End If
        Else
            myItem(k) = ItemNumAr(i, 0)
            myNum1(k) = ItemNumAr(i, 1)
            myNum2(k) = ItemNumAr(i, 2)
        End If
    Next j
    k = k + 1
Next i
ReDim myAr(UBound(myItem), 2)
For i = LBound(myAr) To UBound(myAr)
    myAr(i, 0) = myItem(i)
    myAr(i, 1) = myNum1(i)
    myAr(i, 2) = myNum2(i)
Next i
Erase myItem
Erase myNum1
Erase myNum2
'ここまでで検索すべき範囲を限定しました．

'6000字超で投稿できないため続きます．

Answer 1

'承前

'ここからは上位食品名を取得するコードです．
'Item_Numberの間にある日本語を取得します．
myStrPtn2 = "^(\[|\()?[a-zA-Z]+"
With myRegExp1
    .Pattern = myStrPtn2
    .IgnoreCase = True
    .Global = True
End With
k = 0
For i = LBound(tmpAr) To UBound(tmpAr)
    For j = LBound(myAr) To UBound(myAr)
        If CLng(myAr(j, 1)) < i And _
           CLng(myAr(j, 2)) > i And _
           myRegExp1.Test(tmpAr(i, 1)) _
        Then
            ReDim Preserve myGroupNamJP(k)
            ReDim Preserve myGroupNumJP(k)
            ReDim Preserve myGroupNamEN(k)
            ReDim Preserve myGroupNumEN(k)
            myGroupNamJP(k) = tmpAr(i - 1, 1) & _
                           tmpAr(i - 1, 2) & _
                           tmpAr(i - 1, 3) & _
                           tmpAr(i - 1, 4) & _
                           tmpAr(i - 1, 5) & _
                           tmpAr(i - 1, 6)
            myGroupNumJP(k) = i - 1
            myGroupNamEN(k) = RTrim(tmpAr(i, 1) & " " & _
                         Replace(tmpAr(i, 2), "*", "") & " " & _
                         Replace(tmpAr(i, 3), "*", "") & " " & _
                         Replace(tmpAr(i, 4), "*", "") & " " & _
                         Replace(tmpAr(i, 5), "*", "") & " " & _
                         Replace(tmpAr(i, 6), "*", ""))
            myGroupNumEN(k) = i
        Else
            k = k - 1
        End If
        k = k + 1
    Next j
Next i
ReDim GroupAr(UBound(myGroupNamJP), 3)
For i = LBound(GroupAr) To UBound(GroupAr)
    GroupAr(i, 0) = myGroupNamJP(i)
    GroupAr(i, 1) = myGroupNumJP(i)
    GroupAr(i, 2) = myGroupNamEN(i)
    GroupAr(i, 3) = myGroupNumEN(i)
Next i
'ここまででGroupArに上位食品名，行番号，英語の上位食品名とその行番号を取得しました．
'しかしCancel_Arにある除去すべき集合も混じっており，ここからそれを除去します．
Erase myGroupNamJP
Erase myGroupNumJP
Erase myGroupNamEN
Erase myGroupNumEN
k = 0
For i = LBound(GroupAr) To UBound(GroupAr)
    ReDim Preserve myGroupNamJP(k)
    ReDim Preserve myGroupNumJP(k)
    ReDim Preserve myGroupNamEN(k)
    ReDim Preserve myGroupNumEN(k)
    myGroupNamJP(k) = GroupAr(i, 0)
    myGroupNumJP(k) = GroupAr(i, 1)
    myGroupNamEN(k) = GroupAr(i, 2)
    myGroupNumEN(k) = GroupAr(i, 3)
    k = k + 1
    For j = LBound(Cancel_Ar) To UBound(Cancel_Ar)
        If CLng(Cancel_Ar(j, 1)) < CLng(GroupAr(i, 1)) And _
           CLng(GroupAr(i, 1)) < CLng(Cancel_Ar(j, 2)) _
        Then
            k = k - 1
        End If
    Next j
Next i
ReDim GroupAr(UBound(myGroupNamJP), 3)
With myRegExp1
    .Pattern = endStrPtn
    .IgnoreCase = True
    .Global = True
End With
With myRegExp2
    .Pattern = JapStrPtn
    .IgnoreCase = True
    .Global = True
End With
For i = LBound(GroupAr) To UBound(GroupAr)
    myGroupNamJP(i) = myRegExp1.Replace(myGroupNamJP(i), "")    '閉じ括弧付きの数字を除去
    myGroupNamEN(i) = myRegExp1.Replace(myGroupNamEN(i), "")
    myGroupNamEN(i) = RTrim(myRegExp2.Replace(myGroupNamEN(i), "")) '英語以外を除去
    GroupAr(i, 0) = myGroupNamJP(i)         '上位食品名（日）
    GroupAr(i, 1) = myGroupNumJP(i)         '行番号
    GroupAr(i, 2) = myGroupNamEN(i)         '上位食品名（英）
    GroupAr(i, 3) = myGroupNumEN(i)         '行番号
Next i
ReDim Preserve myAr(UBound(myAr), 4)
k = 0
For i = LBound(myAr) To UBound(myAr)
    tmpStr = ""
    For j = LBound(GroupAr) To UBound(GroupAr)      '検索範囲と上位食品行番号がかぶる場合
        If CLng(myAr(i, 1)) < CLng(GroupAr(j, 1)) And _
                              CLng(GroupAr(j, 3)) < CLng(myAr(i, 2)) Then
            tmpStr = tmpStr & GroupAr(j, 0)         '上位食品名を連ねていく
            myAr(i, 4) = GroupAr(j, 1)              '行番号は最後のだけ取得
        End If
    Next j
    If tmpStr = "" Then
        myAr(i, 3) = myAr(i - 1, 3)         '前レコードの内容を引き継ぎたい
        myAr(i, 4) = myAr(i - 1, 4)
    Else
        myAr(i, 3) = tmpStr                 '上位食品名をそこから取得する
    End If
    k = k + 1
Next i
Set mySht = Worksheets.Add
With mySht
    .Range("A1").Value = "Item_Number"
    .Range("B1").Value = "前行番号"
    .Range("C1").Value = "行番号"
    .Range("D1").Value = "上位食品名"
    .Range("E1").Value = "上位食品行番号"
    .Range("G1").Value = "上位食品名（日）"
    .Range("H1").Value = "行番号"
    .Range("I1").Value = "上位食品名（英）"
    .Range("J1").Value = "行番号"
    .Range("A2:E450") = myAr
    .Range("G2:J250") = GroupAr
End With
Set mySht = Nothing
Set myRng = Nothing
Set myRegExp1 = Nothing
End Sub

Answer 2

補足です．

コードを実行した結果の一部は下記（１）のようになりますが，（２）のような結果が欲しいのです．

（１）
A列 B列 C列 D列
01012 43 50 こむぎ[玄穀]国産
01013 51 54 輸入
01014 55 56 輸入
01015 57 62 [小麦粉]薄力粉
01016 63 64 [小麦粉]薄力粉
01018 65 549 中力粉
01019 550 551 中力粉
01020 552 555 強力粉
01021 556 557 強力粉
01023 558 560 強力粉
01024 561 564 プレミックス粉
01025 565 568 プレミックス粉

（２）
A列 B列 C列
01012 穀物 こむぎ[玄穀]国産
01013 穀物 こむぎ[玄穀]輸入
01014 穀物 こむぎ[玄穀]輸入
01015 穀物 こむぎ[小麦粉]薄力粉
01016 穀物 こむぎ[小麦粉]薄力粉
01018 穀物 こむぎ[小麦粉]中力粉
01019 穀物 こむぎ[小麦粉]中力粉
01020 穀物 こむぎ[小麦粉]強力粉
01021 穀物 こむぎ[小麦粉]強力粉
01023 穀物 こむぎ[小麦粉]強力粉
01024 穀物 こむぎ[小麦粉]プレミックス粉
01025 穀物 こむぎ[小麦粉]プレミックス粉

B列の食品群は比較的簡単に取得できるのですが，ツリー構造として考えると

 

 

 

01012	こむぎ─[玄穀]┬国産
01013	│		　├輸入
01014	│		　└輸入
01015	├[小麦粉]─薄力粉
01016	└[小麦粉]─薄力粉
01018		├中力粉
01019		├中力粉
01020		├強力粉
01021		├強力粉
01023		├強力粉
01024		├プレミックス粉
01025		└プレミックス粉


という形になります．大分類以下細目までノードを正しく補いながら文字列を作成するところに困難を感じています．

また階層数が不定ですので，ここらあたりの処理も困難を感じています．

Answer 3

長いので詳しくは見ていませんが、このような場合は再帰という手法を使うのが一般的です。「Excel VBA 再帰」などで検索してみて下さい。

（参考）
再帰呼び出しの考え方
http://www.moug.net/tech/exvba/0150117.html

 

---

★良い回答には回答済みマークを付けよう！ わんくま同盟 MVP - Visual C# http://d.hatena.ne.jp/trapemiya/

Answer 4

ありがとうございました．

探してみます．