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

  • 質問

  • お世話になります.
    Windows7 (64bit) EXCEL 2010 (64bit) VBAで上記の点について困っています.
    上記のサイトにあるPDFからテキスト情報を抽出しております.
    から
    まで
    データ構造は
    の5ページに有るように,食品群,区分,大分類,中分類,小分類,細目の6階層の木構造となっています.
    ですが各階層に必ずノードがあるわけではなく,省略されているノードがかなりあります.
    木構造を取得するには構成展開という手法があると分かりましたが,具体的にどうするかがわかりません.
    自分で書いたコードでは途中のノードからしか取得できていません.
    VBAを使用するまでの手順は上記ページにありますが,要はコピペです.
    最終的に欲しい形は
    A列 Item_Number
    B列 "食品群"
    C列 "大分類"
    D列 "中分類"
    E列 "小分類"
    F列 "細目"
    となります.ただ,どうしても空欄ができてしまう箇所があるため,現状では
    A列 Item_Number
    B列 "食品群"
    C列 "大分類"&"中分類"&"小分類"&"細目"
    の形を取っています.Item_Numberは5桁の数値,食品群はItem_Numberの上2桁です.
    よろしくお願い致します.
    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字超で投稿できないため続きます.


    • 編集済み じふ 2012年1月30日 0:37
    2012年1月29日 14:32

回答

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

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

     


    ★良い回答には回答済みマークを付けよう! わんくま同盟 MVP - Visual C# http://d.hatena.ne.jp/trapemiya/
    • 回答としてマーク じふ 2012年1月30日 20:57
    2012年1月30日 9:10
    モデレータ

すべての返信

  • '承前

    'ここからは上位食品名を取得するコードです.
    '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
    
    


    • 編集済み じふ 2012年1月30日 0:35
    2012年1月29日 14:33
  • 補足です.

    コードを実行した結果の一部は下記(1)のようになりますが,(2)のような結果が欲しいのです.

    (1)
    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 プレミックス粉

    (2)
    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		└プレミックス粉
    

    という形になります.大分類以下細目までノードを正しく補いながら文字列を作成するところに困難を感じています.
    また階層数が不定ですので,ここらあたりの処理も困難を感じています.

    • 編集済み じふ 2012年1月30日 7:27
    2012年1月30日 7:24
  • 長いので詳しくは見ていませんが、このような場合は再帰という手法を使うのが一般的です。「Excel VBA 再帰」などで検索してみて下さい。

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

     


    ★良い回答には回答済みマークを付けよう! わんくま同盟 MVP - Visual C# http://d.hatena.ne.jp/trapemiya/
    • 回答としてマーク じふ 2012年1月30日 20:57
    2012年1月30日 9:10
    モデレータ
  • ありがとうございました.

    探してみます.

    2012年1月30日 20:57