日: 2012年5月25日

Classify the Item_Number of the ‘Standard Tables of Food Composition in Japan 2010′, Part 2

According to the article, download the PDF files ‘1299012_1.pdf’ to ‘1299012_18.pdf’. Corresponding to each PDF file in PDF files, copy all text from one file and option paste to one worksheet. As a result, you would make 18 worksheets in a book. In the first tab of ‘Text File Wizard’, select option ‘The data field separated by delimiters such as comma or tab’. Go to the last tab without any change in second tab. In the last tab, change option data type of the first column to ‘String’. Mainly in column A of all worksheets, you have to fix cell value by yourself. Save the book as ‘Category.xlsm’. Furthermore, download the EXCEL book from this site, copy worksheet from it to ‘Category.xlsm’ which you previously prepared, and change the sheet name to ‘Sheet0’.

Copy or move the worksheet, which you made at Classify the Item_Number of the ‘Standard Tables of Food Composition in Japan 2010′, Part 1, to ‘Category.xlsm’. As a result, ‘Category.xlsm’ book has 20 worksheets. Press ‘Alt’ key and ‘F11’ key to launch VBE, insert module and run the code below. The code makes ‘M_CATEGORY’ sheet. 

Option Explicit
Sub Select_Class()
Dim tmpSht              As Worksheet
Dim tmpRng              As Range
Dim tmpArray            As Variant
Dim workArray           As Variant
Dim h                   As Long
Dim i                   As Long
Dim j                   As Long
Dim k                   As Long
Dim l                   As Long
Dim m                   As Long
Dim n                   As Long
Dim p                   As Long
Dim q                   As Long
Dim r                   As Long
Dim RegExp_Japanese     As Object
Dim RegExp_English      As Object
Dim RegExp_ItemNum      As Object
Const PtnJPN            As String = "[^A-Za-z0-9'\.\-\*]{2,}"
Const PtnENG            As String = "^[A-Za-z0-9'\,\.\-\%]+$"
Const PtnItemNum        As String = "^[0-9]{5}$"
Dim Item_Number()       As String
Dim JapaneseItem()      As String
Dim EnglishItem()       As String
Dim EnglishString       As String
Dim JapaneseClass()     As String
Dim English_Class()     As String
Dim ClassStringEN       As String
Dim ItemNumArray()      As String
Dim ItemENGArray()      As String
Dim ClassArrayJP()      As String
Dim ClassArrayEN()      As String
Dim RegExp_AngleBracket As Object
Dim RegExp_RoundStartJP As Object
Dim RegExp_RoundStartEN As Object
Dim RegExp_RoundExitEN  As Object
Const Ptn_Round_Start   As String = "^(\(|（)"
Const Ptn_Round_Exit    As String = "(\)|）)$"
Dim StringRoundEnglish  As String
Dim SubClassJapanese()  As String
Dim SubClass_English()  As String
Dim RegExp_Square_Start As Object
Dim RegExp_SquareExitEN As Object
Const Ptn_Angle_Start   As String = "^[<＜]"
Const Ptn_SquareStart   As String = "^\["
Const Ptn_Square_Exit   As String = "\]$"
Dim MidleClassJP()      As String
Dim MidleClassEN()      As String
Dim StrMidClassENG      As String
Dim SubClass_JPN()      As String
Dim SubClass_ENG()      As String
Dim mySht               As Worksheet
Dim myRng               As Range
Dim myAr                As Variant
Dim workArray2()        As String
Dim workArray3()        As String
Dim mySht2              As Worksheet
Dim myRng2              As Range
Dim myAr2               As Variant
Dim CEREALS             As Long
Dim POTATOES            As Long
Dim SUGARS              As Long
Dim PULSES              As Long
Dim NUTS                As Long
Dim VEGETABLES          As Long
Dim FRUITS              As Long
Dim MUSHROOMS           As Long
Dim ALGAE               As Long
Dim FISHES              As Long
Dim MEATS               As Long
Dim EGGS                As Long
Dim MILK                As Long
Dim OIL                 As Long
Dim CONFECTIONERIES     As Long
Dim BEVERAGES           As Long
Dim SEASONINGS          As Long
Dim PREPARED            As Long
    Set RegExp_Japanese = CreateObject("VBScript.RegExp")
    With RegExp_Japanese
        .Pattern = PtnJPN
        .IgnoreCase = True
        .Global = True
    End With
    Set RegExp_English = CreateObject("VBScript.RegExp")
    With RegExp_English
        .Pattern = PtnENG
        .IgnoreCase = True
        .Global = True
    End With
    Set RegExp_ItemNum = CreateObject("VBScript.RegExp")
    With RegExp_ItemNum
        .Pattern = PtnItemNum
        .IgnoreCase = True
        .Global = True
    End With
    Set RegExp_Square_Start = CreateObject("VBScript.RegExp")
    With RegExp_Square_Start
        .Pattern = Ptn_SquareStart
        .IgnoreCase = True
        .Global = True
    End With
    Set RegExp_SquareExitEN = CreateObject("VBScript.RegExp")
    With RegExp_SquareExitEN
        .Pattern = "[A-Za-z0-9'\,\.\-\%]+" & Ptn_Square_Exit
        .IgnoreCase = True
        .Global = True
    End With
    Set RegExp_RoundStartJP = CreateObject("VBScript.RegExp")
    With RegExp_RoundStartJP
        .Pattern = Ptn_Round_Start & "[^A-Za-z0-9'\.\-\*]{2,}"
        .IgnoreCase = True
        .Global = True
    End With
    Set RegExp_RoundStartEN = CreateObject("VBScript.RegExp")
    With RegExp_RoundStartEN
        .Pattern = Ptn_Round_Start & "[A-Za-z'\,\.\-\%]+"
    End With
    Set RegExp_RoundExitEN = CreateObject("VBScript.RegExp")
    With RegExp_RoundExitEN
        .Pattern = "[A-Za-z0-9'\,\.\-\%]+" & Ptn_Round_Exit
        .IgnoreCase = True
        .Global = True
    End With
j = 0
k = 0
l = 0
m = 0
q = 0
For Each tmpSht In Worksheets
    If tmpSht.Name = "M_CATEGORY" Then
        MsgBox prompt:="This book already has M_CATEGORY sheet." & vbCrLf & _
                       "Exit procedure.", _
              Buttons:=vbOKOnly, _
                Title:="Internal Error"
        Exit Sub
    End If
    If tmpSht.Name <> "Sheet0" And _
       tmpSht.Name <> "Sheet00" And _
       tmpSht.Name <> "Result" Then
        Set tmpRng = tmpSht.UsedRange
        tmpArray = tmpRng
        workArray = NoCancelArray(tmpArray)
        For h = LBound(workArray) To UBound(workArray)
            For i = workArray(h, 0) To workArray(h, 1)
                On Error Resume Next
                If RegExp_ItemNum.Test(tmpArray(i, 1)) And _
                   tmpArray(i, 2) <> "（欠番）" Then
                    EnglishString = ""
                    ReDim Preserve Item_Number(j)
                    ReDim Preserve JapaneseItem(j)
                    ReDim Preserve EnglishItem(j)
                    For p = 1 To 6
                        If RegExp_English.Test(tmpArray(i + 1, p)) Then
                            EnglishString = EnglishString & " " & tmpArray(i + 1, p)
                            EnglishString = Trim(EnglishString)
                        Else
                            Exit For
                        End If
                    Next p
                    Item_Number(j) = tmpArray(i, 1)
                    JapaneseItem(j) = tmpArray(i, 2)
                    EnglishItem(j) = EnglishString
                    j = j + 1
                End If
                On Error GoTo 0
                If RegExp_Japanese.Test(tmpArray(i, 1)) And _
                   RegExp_English.Test(tmpArray(i + 1, 1)) Then
                    ClassStringEN = ""
                    ReDim Preserve JapaneseClass(k)
                    ReDim Preserve English_Class(k)
                    For p = 1 To 6
                        If RegExp_English.Test(tmpArray(i + 1, p)) Then
                            ClassStringEN = ClassStringEN & " " & tmpArray(i + 1, p)
                            ClassStringEN = Trim(ClassStringEN)
                        Else
                            Exit For
                        End If
                    Next p
                    JapaneseClass(k) = tmpArray(i, 1)
                    English_Class(k) = ClassStringEN
                    k = k + 1
                End If
                If RegExp_Square_Start.Test(tmpArray(i, 1)) And _
                   RegExp_Square_Start.Test(tmpArray(i + 1, 1)) Then
                    StrMidClassENG = ""
                    ReDim Preserve MidleClassJP(l)
                    ReDim Preserve MidleClassEN(l)
                    For p = 1 To 6
                        StrMidClassENG = StrMidClassENG + " " + tmpArray(i + 1, p)
                        StrMidClassENG = Trim(StrMidClassENG)
                        If RegExp_SquareExitEN.Test(tmpArray(i + 1, p)) Then Exit For
                    Next p
                    MidleClassJP(l) = tmpArray(i, 1)
                    MidleClassEN(l) = StrMidClassENG
                    l = l + 1
                End If
                If RegExp_RoundStartJP.Test(tmpArray(i, 1)) And _
                   RegExp_RoundStartEN.Test(tmpArray(i + 1, 1)) Then
                    StringRoundEnglish = ""
                    ReDim Preserve SubClassJapanese(m)
                    ReDim Preserve SubClass_English(m)
                    For p = 1 To 6
                        StringRoundEnglish = StringRoundEnglish & " " & tmpArray(i + 1, p)
                        StringRoundEnglish = Trim(StringRoundEnglish)
                        If RegExp_RoundExitEN.Test(tmpArray(i + 1, p)) Then Exit For
                    Next p
                    tmpArray(i, 1) = Replace(tmpArray(i, 1), "(", "（")
                    tmpArray(i, 1) = Replace(tmpArray(i, 1), ")", "）")
                    SubClassJapanese(m) = tmpArray(i, 1)
                    StringRoundEnglish = Replace(StringRoundEnglish, "（", "(")
                    StringRoundEnglish = Replace(StringRoundEnglish, "）", ")")
                    SubClass_English(m) = StringRoundEnglish
                    m = m + 1
                End If
            Next i
        Next h
        q = q + 1
    End If
Next tmpSht
Set mySht = Worksheets("Sheet0")
Set myRng = Intersect(mySht.Range("A:H"), mySht.UsedRange)
myAr = myRng
ReDim workArray2(UBound(myAr) - 1, 16)
For i = LBound(workArray2) To UBound(workArray2)
    workArray2(i, 0) = myAr(i + 1, 1)
    workArray2(i, 1) = myAr(i + 1, 2)
    workArray2(i, 2) = myAr(i + 1, 3)
    myAr(i + 1, 4) = Replace(myAr(i + 1, 4), "(", "（")
    myAr(i + 1, 4) = Replace(myAr(i + 1, 4), ")", "）")
    workArray2(i, 6) = myAr(i + 1, 4)
    workArray2(i, 8) = myAr(i + 1, 5)
    workArray2(i, 10) = myAr(i + 1, 6)
    workArray2(i, 12) = myAr(i + 1, 7)
    workArray2(i, 14) = myAr(i + 1, 8)
Next i
Set mySht2 = Worksheets("Result")
Set myRng2 = mySht2.UsedRange
myAr2 = myRng2
For i = LBound(workArray2) To UBound(workArray2)
    For k = LBound(JapaneseClass) To UBound(JapaneseClass)
        If workArray2(i, 2) = JapaneseClass(k) Then
           workArray2(i, 3) = English_Class(k)
        End If
        If workArray2(i, 4) = JapaneseClass(k) Then
           workArray2(i, 5) = English_Class(k)
        End If
        If workArray2(i, 8) = JapaneseClass(k) Then
           workArray2(i, 9) = English_Class(k)
        End If
        If workArray2(i, 12) = JapaneseClass(k) Then
           workArray2(i, 13) = English_Class(k)
        End If
    Next k
    For m = LBound(SubClassJapanese) To UBound(SubClassJapanese)
        If workArray2(i, 6) = SubClassJapanese(m) Then
           workArray2(i, 7) = SubClass_English(m)
        End If
    Next m
    For l = UBound(MidleClassJP) To LBound(MidleClassJP) Step -1
        If workArray2(i, 10) = MidleClassJP(l) Then
           workArray2(i, 11) = MidleClassEN(l)
        End If
    Next l
    For r = LBound(myAr2) To UBound(myAr2)
        If workArray2(i, 0) = myAr2(r, 1) Then
            workArray2(i, 4) = myAr2(r, 5)
            On Error Resume Next
            Select Case True
            Case workArray2(i, 0) >= "10001" And workArray2(i, 0) <= "10278"
                 workArray2(i, 4) = "＜魚類＞"
            Case workArray2(i, 0) >= "10319" And workArray2(i, 0) <= "10341"
                 workArray2(i, 4) = "＜えび・かに類＞"
            Case workArray2(i, 0) >= "10342" And workArray2(i, 0) <= "10362"
                 workArray2(i, 4) = "＜いか・たこ類＞"
            Case workArray2(i, 0) >= "10376" And workArray2(i, 0) <= "10388"
                 workArray2(i, 4) = "＜水産練り製品＞"
            Case workArray2(i, 0) >= "11205" And workArray2(i, 0) <= "11240"
                 workArray2(i, 4) = "＜鳥肉類＞"
            Case workArray2(i, 0) >= "11245" And workArray2(i, 0) <= "11246"
                 workArray2(i, 4) = "＜獣肉類＞"
            Case workArray2(i, 0) >= "11247" And workArray2(i, 0) <= "11247"
                 workArray2(i, 4) = "＜鳥肉類＞"
            Case workArray2(i, 0) >= "13001" And workArray2(i, 0) <= "13050"
                 workArray2(i, 4) = "＜牛乳及び乳製品＞"
            Case workArray2(i, 0) >= "15001" And workArray2(i, 0) <= "15040"
                 workArray2(i, 4) = "＜和生菓子・和半生菓子類＞"
            Case workArray2(i, 0) >= "15041" And workArray2(i, 0) <= "15068"
                 workArray2(i, 4) = "＜和干菓子類＞"
            Case workArray2(i, 0) >= "15069" And workArray2(i, 0) <= "15072"
                 workArray2(i, 4) = "＜菓子パン類＞"
            Case workArray2(i, 0) >= "15073" And workArray2(i, 0) <= "15085"
                 workArray2(i, 4) = "＜ケーキ・ペストリー類＞"
            Case workArray2(i, 0) >= "15086" And workArray2(i, 0) <= "15091"
                 workArray2(i, 4) = "＜デザート菓子類＞"
            Case workArray2(i, 0) >= "15092" And workArray2(i, 0) <= "15100"
                 workArray2(i, 4) = "＜ビスケット類＞"
            Case workArray2(i, 0) >= "15101" And workArray2(i, 0) <= "15104"
                 workArray2(i, 4) = "＜スナック類＞"
            Case workArray2(i, 0) >= "15105" And workArray2(i, 0) <= "15113"
                 workArray2(i, 4) = "＜キャンデー類＞"
            Case workArray2(i, 0) >= "15114" And workArray2(i, 0) <= "15116"
                 workArray2(i, 4) = "＜チョコレート類＞"
            Case workArray2(i, 0) >= "15117" And workArray2(i, 0) <= "15117"
                 workArray2(i, 4) = "＜果実菓子類＞"
            Case workArray2(i, 0) >= "15118" And workArray2(i, 0) <= "15120"
                 workArray2(i, 4) = "＜チューインガム類＞"
            Case workArray2(i, 0) >= "16001" And workArray2(i, 0) <= "16032"
                 workArray2(i, 4) = "＜アルコール飲料類＞"
            Case workArray2(i, 0) >= "16033" And workArray2(i, 0) <= "16044"
                 workArray2(i, 4) = "＜茶類＞"
            Case workArray2(i, 0) >= "16045" And workArray2(i, 0) <= "16049"
                 workArray2(i, 4) = "＜コーヒー・ココア類＞"
            Case workArray2(i, 0) >= "16050" And workArray2(i, 0) <= "16055"
                 workArray2(i, 4) = "＜その他＞"
            Case workArray2(i, 0) >= "17001" And workArray2(i, 0) <= "17054"
                 workArray2(i, 4) = "＜調味料類＞"
            Case workArray2(i, 0) >= "17055" And workArray2(i, 0) <= "17081"
                 workArray2(i, 4) = "＜香辛料類＞"
            Case workArray2(i, 0) >= "17082" And workArray2(i, 0) <= "17084"
                 workArray2(i, 4) = "＜その他＞"
            End Select
            On Error GoTo 0
            workArray2(i, 5) = myAr2(r, 6)
            On Error Resume Next
            Select Case True
            Case workArray2(i, 0) >= "10001" And workArray2(i, 0) <= "10278"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "10319" And workArray2(i, 0) <= "10341"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "10342" And workArray2(i, 0) <= "10362"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "10376" And workArray2(i, 0) <= "10388"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "11205" And workArray2(i, 0) <= "11240"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "11245" And workArray2(i, 0) <= "11246"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "11247" And workArray2(i, 0) <= "11247"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "13001" And workArray2(i, 0) <= "13050"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15001" And workArray2(i, 0) <= "15040"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15041" And workArray2(i, 0) <= "15068"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15069" And workArray2(i, 0) <= "15072"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15073" And workArray2(i, 0) <= "15085"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15086" And workArray2(i, 0) <= "15091"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15092" And workArray2(i, 0) <= "15100"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15101" And workArray2(i, 0) <= "15104"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15105" And workArray2(i, 0) <= "15113"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15114" And workArray2(i, 0) <= "15116"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15117" And workArray2(i, 0) <= "15117"
                 workArray2(i, 5) = "＜CANDIED FRUITS＞"
            Case workArray2(i, 0) >= "15118" And workArray2(i, 0) <= "15120"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "16001" And workArray2(i, 0) <= "16032"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "16033" And workArray2(i, 0) <= "16044"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "16045" And workArray2(i, 0) <= "16049"
                 workArray2(i, 5) = "COFFEES AND COCOAS>"
            Case workArray2(i, 0) >= "16050" And workArray2(i, 0) <= "16055"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "17001" And workArray2(i, 0) <= "17054"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "17055" And workArray2(i, 0) <= "17081"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "17082" And workArray2(i, 0) <= "17084"
                 workArray2(i, 5) = ""
            End Select
            On Error GoTo 0
            If workArray2(i, 6) <> "" And _
               workArray2(i, 7) = "" Then
                workArray2(i, 7) = myAr2(r, 8)
            End If
            If workArray2(i, 8) <> "" And _
               workArray2(i, 9) = "" Then
                If myAr2(r, 10) = "" Then
                    workArray2(i, 9) = myAr2(r, 15)
                Else
                    workArray2(i, 9) = myAr2(r, 10)
                End If
            End If
            If workArray2(i, 12) <> "" And _
               workArray2(i, 13) = "" Then
                workArray2(i, 13) = myAr2(r, 15)
            End If
            If workArray2(i, 14) <> "" Then
                workArray2(i, 15) = myAr2(r, 15)
            End If
            workArray2(i, 16) = myAr2(r, 11)
        End If
        Select Case True
            Case workArray2(i, 0) = "14004a"
                workArray2(i, 9) = "Safflower oil"
            Case workArray2(i, 0) = "14011a"
                workArray2(i, 9) = "Sunflower oil"
            Case workArray2(i, 0) = "14011b"
                workArray2(i, 9) = "Sunflower oil"
        End Select
    Next r
Next i
ReDim workArray3(UBound(workArray2), UBound(workArray2, 2))
For i = LBound(workArray3) To UBound(workArray3)
    workArray3(i, 0) = workArray2(i, 0)
    workArray3(i, 1) = workArray2(i, 1)
    workArray3(i, 2) = workArray2(i, 2)
    workArray3(i, 3) = workArray2(i, 4)
    workArray3(i, 4) = workArray2(i, 6)
    workArray3(i, 5) = workArray2(i, 8)
    workArray3(i, 6) = workArray2(i, 10)
    workArray3(i, 7) = workArray2(i, 12)
    workArray3(i, 8) = workArray2(i, 14)
    workArray3(i, 9) = workArray2(i, 3)
    workArray3(i, 10) = workArray2(i, 5)
    workArray3(i, 11) = workArray2(i, 7)
    workArray3(i, 12) = workArray2(i, 16)
    workArray3(i, 13) = workArray2(i, 9)
    workArray3(i, 14) = workArray2(i, 11)
    workArray3(i, 15) = workArray2(i, 13)
    workArray3(i, 16) = workArray2(i, 15)
Next i
Set mySht = Worksheets.Add
With mySht
    .Name = "M_CATEGORY"
    .Range("A1").Value = "ItemNumber"
    .Range("B1").Value = "FoodGroupNumber"
    .Range("C1").Value = "FoodGroupJP"
    .Range("D1").Value = "SubGroupJP"
    .Range("E1").Value = "SubCategoryJP"
    .Range("F1").Value = "MajorCategoryJP"
    .Range("G1").Value = "MediumCategoryJP"
    .Range("H1").Value = "MinorCategoryJP"
    .Range("I1").Value = "DetailsJP"
    .Range("J1").Value = "FoodGroupEN"
    .Range("K1").Value = "SubGroupEN"
    .Range("L1").Value = "SubCategoryEN"
    .Range("M1").Value = "AcademicName"
    .Range("N1").Value = "MajorCategoryEN"
    .Range("O1").Value = "MediumCategoryEN"
    .Range("P1").Value = "MinorCategoryEN"
    .Range("Q1").Value = "DetailsEN"
    .Range("A2:Q1892") = workArray3
End With
Set tmpSht = Nothing
Set tmpRng = Nothing
Set tmpArray = Nothing
Set workArray = Nothing
Set RegExp_Japanese = Nothing
Set RegExp_English = Nothing
Set RegExp_ItemNum = Nothing
Set RegExp_Square_Start = Nothing
Set RegExp_SquareExitEN = Nothing
Set RegExp_RoundStartJP = Nothing
Set RegExp_RoundStartEN = Nothing
Set RegExp_RoundExitEN = Nothing
Erase Item_Number()
Erase JapaneseItem()
Erase EnglishItem()
Erase JapaneseClass()
Erase English_Class()
Erase ItemNumArray()
Erase ItemENGArray()
Erase ClassArrayJP()
Erase ClassArrayEN()
Erase SubClassJapanese()
Erase SubClass_English()
Erase MidleClassJP()
Erase MidleClassEN()
Erase SubClass_JPN()
Erase SubClass_ENG()
Erase workArray2()
Erase workArray3()
Set mySht = Nothing
Set myRng = Nothing
Set myAr = Nothing
Set mySht2 = Nothing
Set myRng2 = Nothing
Set myAr2 = Nothing
End Sub

Function NoCancelArray(ByRef Sh As Variant) As Variant
Dim mySht           As Variant
Dim myRng           As Range
Dim tmpAr           As Variant
Dim i               As Long
Dim j               As Long
Dim RegExpCancel    As Object
Dim RegExp_Exit     As Object
Const StrCancel     As String = "^(1\)|residues)$"
Dim CancelItem()    As String
Dim CancelRow1()    As String
Dim CancelRow2()    As String
Dim myCancelAr()    As String
Dim Cancel_Array()  As String
    Set RegExpCancel = CreateObject("VBScript.RegExp")
    With RegExpCancel
        .Pattern = StrCancel
        .IgnoreCase = True
        .Global = True
    End With
tmpAr = Sh
j = 0
For i = LBound(tmpAr) To UBound(tmpAr)
    If RegExpCancel.Test(tmpAr(i, 1)) Then
        ReDim Preserve CancelItem(j)
        ReDim Preserve CancelRow1(i)
        CancelItem(j) = tmpAr(i, 1)
        CancelRow1(j) = i
        j = j + 1
    End If
Next i
ReDim myCancelAr(UBound(CancelItem), 1)
For j = LBound(myCancelAr) To UBound(myCancelAr)
    myCancelAr(j, 0) = CancelItem(j)
    myCancelAr(j, 1) = CancelRow1(j)
Next j
ReDim Preserve myCancelAr(UBound(myCancelAr), 2)
j = 0
For i = LBound(myCancelAr) To UBound(myCancelAr) - 1
    If myCancelAr(i, 0) = "1)" Then
        If UBound(myCancelAr) >= 2 Then
            If myCancelAr(i + 2, 0) = "residues" Then
                myCancelAr(i, 2) = myCancelAr(i + 2, 1)
            Else
                myCancelAr(i, 2) = myCancelAr(i + 1, 1)
            End If
        Else
            myCancelAr(i, 2) = myCancelAr(i + 1, 1)
        End If
        j = j + 1
    End If
Next i
Erase CancelRow1
j = 0
ReDim CancelRow1(j)
ReDim CancelRow2(j)
CancelRow1(j) = myCancelAr(j, 1)
CancelRow2(j) = myCancelAr(j, 2)
For i = LBound(myCancelAr) + 1 To UBound(myCancelAr)
    If myCancelAr(i, 0) = "1)" And _
       myCancelAr(i - 1, 0) <> "1)" Then
        j = j + 1
        ReDim Preserve CancelRow1(j)
        ReDim Preserve CancelRow2(j)
        CancelRow1(j) = myCancelAr(i, 1)
        CancelRow2(j) = myCancelAr(i, 2)
    End If
Next i
ReDim Cancel_Array(UBound(CancelRow1), 1)
j = 0
For j = LBound(Cancel_Array) To UBound(Cancel_Array)
    Cancel_Array(j, 0) = CancelRow1(j)
    Cancel_Array(j, 1) = CancelRow2(j)
Next j
j = 0
Cancel_Array(j, 0) = 1
Cancel_Array(j, 1) = CancelRow1(j)
For j = LBound(Cancel_Array) + 1 To UBound(Cancel_Array)
    Cancel_Array(j, 0) = CancelRow2(j - 1) + 1
    Cancel_Array(j, 1) = CancelRow1(j) - 1
Next j
NoCancelArray = Cancel_Array
End Function

I have counted number of modified cells. It was more than 2400. I could not write complete code without manual processing. It is the responsibility of the Ministry of Education, Culture, Sports, Science & Technology in Japan (MEXT).

References:
CSV file of the ‘Standard Tables of Food Composition in Japan 2010′
Classify the Item_Number of the ‘Standard Tables of Food Composition in Japan 2010′, Part 1

日本食品標準成分表2010の食品番号をカテゴリー分類する　その2

日本食品標準成分表2010』のPDFを.txtファイルに変換するの記事を参考に，ファイル名 “1299012_1.pdf” から “1299012_18.pdf” までのファイルをダウンロードします．PDF1ファイルの全テキストをコピーしてワークシート1枚に貼り付けのオプションでペーストします．テキストファイルウィザード1/3では元のデータ形式で『カンマやタブなどの区切り文字によってフィールドごとに区切られたデータ』を選択します．テキストファイルウィザード2/3では特に変更なく次へ進みます．テキストファイルウィザード3/3では最初のカラムの列のデータ形式のみ『文字列』に変更して完了をクリックします．この作業をPDFファイル分繰り返します．主にA列に対して若干の修正を施します．さらに Ｗｅｂテク実験室 からダウンロードしたブック “成分表2010.xls” のワークシートをコピーし，シート名を “Sheet0” に変更します．このEXCELのブックに “Category.xlsm” と名前を付けて保存します．

日本食品標準成分表2010の食品番号をカテゴリー分類する　その1で作成した ”Sample.xlsm” ブックから ”Result” シートを “Category.xlsm” ブックに移動又はコピーします．AltキーとF11キーを押下してVBEを起動します．標準モジュールを挿入し，下記コードを貼り付けて実行して下さい．結果として “M_CATEGORY” という名のシートが生成します．

Option Explicit
Sub Select_Class()
Dim tmpSht              As Worksheet
Dim tmpRng              As Range
Dim tmpArray            As Variant
Dim workArray           As Variant
Dim h                   As Long
Dim i                   As Long
Dim j                   As Long
Dim k                   As Long
Dim l                   As Long
Dim m                   As Long
Dim n                   As Long
Dim p                   As Long
Dim q                   As Long
Dim r                   As Long
Dim RegExp_Japanese     As Object
Dim RegExp_English      As Object
Dim RegExp_ItemNum      As Object
Const PtnJPN            As String = "[^A-Za-z0-9'\.\-\*]{2,}"
Const PtnENG            As String = "^[A-Za-z0-9'\,\.\-\%]+$"
Const PtnItemNum        As String = "^[0-9]{5}$"
Dim Item_Number()       As String
Dim JapaneseItem()      As String
Dim EnglishItem()       As String
Dim EnglishString       As String
Dim JapaneseClass()     As String
Dim English_Class()     As String
Dim ClassStringEN       As String
Dim ItemNumArray()      As String
Dim ItemENGArray()      As String
Dim ClassArrayJP()      As String
Dim ClassArrayEN()      As String
Dim RegExp_AngleBracket As Object
Dim RegExp_RoundStartJP As Object
Dim RegExp_RoundStartEN As Object
Dim RegExp_RoundExitEN  As Object
Const Ptn_Round_Start   As String = "^(\(|（)"
Const Ptn_Round_Exit    As String = "(\)|）)$"
Dim StringRoundEnglish  As String
Dim SubClassJapanese()  As String
Dim SubClass_English()  As String
Dim RegExp_Square_Start As Object
Dim RegExp_SquareExitEN As Object
Const Ptn_Angle_Start   As String = "^[<＜]"
Const Ptn_SquareStart   As String = "^\["
Const Ptn_Square_Exit   As String = "\]$"
Dim MidleClassJP()      As String
Dim MidleClassEN()      As String
Dim StrMidClassENG      As String
Dim SubClass_JPN()      As String
Dim SubClass_ENG()      As String
Dim mySht               As Worksheet
Dim myRng               As Range
Dim myAr                As Variant
Dim workArray2()        As String
Dim workArray3()        As String
Dim mySht2              As Worksheet
Dim myRng2              As Range
Dim myAr2               As Variant
Dim CEREALS             As Long
Dim POTATOES            As Long
Dim SUGARS              As Long
Dim PULSES              As Long
Dim NUTS                As Long
Dim VEGETABLES          As Long
Dim FRUITS              As Long
Dim MUSHROOMS           As Long
Dim ALGAE               As Long
Dim FISHES              As Long
Dim MEATS               As Long
Dim EGGS                As Long
Dim MILK                As Long
Dim OIL                 As Long
Dim CONFECTIONERIES     As Long
Dim BEVERAGES           As Long
Dim SEASONINGS          As Long
Dim PREPARED            As Long
    Set RegExp_Japanese = CreateObject("VBScript.RegExp")
    With RegExp_Japanese
        .Pattern = PtnJPN
        .IgnoreCase = True
        .Global = True
    End With
    Set RegExp_English = CreateObject("VBScript.RegExp")
    With RegExp_English
        .Pattern = PtnENG
        .IgnoreCase = True
        .Global = True
    End With
    Set RegExp_ItemNum = CreateObject("VBScript.RegExp")
    With RegExp_ItemNum
        .Pattern = PtnItemNum
        .IgnoreCase = True
        .Global = True
    End With
    Set RegExp_Square_Start = CreateObject("VBScript.RegExp")
    With RegExp_Square_Start
        .Pattern = Ptn_SquareStart
        .IgnoreCase = True
        .Global = True
    End With
    Set RegExp_SquareExitEN = CreateObject("VBScript.RegExp")
    With RegExp_SquareExitEN
        .Pattern = "[A-Za-z0-9'\,\.\-\%]+" & Ptn_Square_Exit
        .IgnoreCase = True
        .Global = True
    End With
    Set RegExp_RoundStartJP = CreateObject("VBScript.RegExp")
    With RegExp_RoundStartJP
        .Pattern = Ptn_Round_Start & "[^A-Za-z0-9'\.\-\*]{2,}"
        .IgnoreCase = True
        .Global = True
    End With
    Set RegExp_RoundStartEN = CreateObject("VBScript.RegExp")
    With RegExp_RoundStartEN
        .Pattern = Ptn_Round_Start & "[A-Za-z'\,\.\-\%]+"
    End With
    Set RegExp_RoundExitEN = CreateObject("VBScript.RegExp")
    With RegExp_RoundExitEN
        .Pattern = "[A-Za-z0-9'\,\.\-\%]+" & Ptn_Round_Exit
        .IgnoreCase = True
        .Global = True
    End With
j = 0
k = 0
l = 0
m = 0
q = 0
For Each tmpSht In Worksheets
    If tmpSht.Name = "M_CATEGORY" Then
        MsgBox prompt:="M_CATEGORYと同名のシートがあります．" & vbCrLf & _
                        "処理を終了します", _
              Buttons:=vbOKOnly, _
                Title:="内部エラー"
        Exit Sub
    End If
    If tmpSht.Name <> "Sheet0" And _
       tmpSht.Name <> "Sheet00" And _
       tmpSht.Name <> "Result" Then
        Set tmpRng = tmpSht.UsedRange
        tmpArray = tmpRng
        workArray = NoCancelArray(tmpArray)
        For h = LBound(workArray) To UBound(workArray)
            For i = workArray(h, 0) To workArray(h, 1)
                On Error Resume Next
                If RegExp_ItemNum.Test(tmpArray(i, 1)) And _
                   tmpArray(i, 2) <> "（欠番）" Then
                    EnglishString = ""
                    ReDim Preserve Item_Number(j)
                    ReDim Preserve JapaneseItem(j)
                    ReDim Preserve EnglishItem(j)
                    For p = 1 To 6
                        If RegExp_English.Test(tmpArray(i + 1, p)) Then
                            EnglishString = EnglishString & " " & tmpArray(i + 1, p)
                            EnglishString = Trim(EnglishString)
                        Else
                            Exit For
                        End If
                    Next p
                    Item_Number(j) = tmpArray(i, 1)
                    JapaneseItem(j) = tmpArray(i, 2)
                    EnglishItem(j) = EnglishString
                    j = j + 1
                End If
                On Error GoTo 0
                If RegExp_Japanese.Test(tmpArray(i, 1)) And _
                   RegExp_English.Test(tmpArray(i + 1, 1)) Then
                    ClassStringEN = ""
                    ReDim Preserve JapaneseClass(k)
                    ReDim Preserve English_Class(k)
                    For p = 1 To 6
                        If RegExp_English.Test(tmpArray(i + 1, p)) Then
                            ClassStringEN = ClassStringEN & " " & tmpArray(i + 1, p)
                            ClassStringEN = Trim(ClassStringEN)
                        Else
                            Exit For
                        End If
                    Next p
                    JapaneseClass(k) = tmpArray(i, 1)
                    English_Class(k) = ClassStringEN
                    k = k + 1
                End If
                If RegExp_Square_Start.Test(tmpArray(i, 1)) And _
                   RegExp_Square_Start.Test(tmpArray(i + 1, 1)) Then
                    StrMidClassENG = ""
                    ReDim Preserve MidleClassJP(l)
                    ReDim Preserve MidleClassEN(l)
                    For p = 1 To 6
                        StrMidClassENG = StrMidClassENG + " " + tmpArray(i + 1, p)
                        StrMidClassENG = Trim(StrMidClassENG)
                        If RegExp_SquareExitEN.Test(tmpArray(i + 1, p)) Then Exit For
                    Next p
                    MidleClassJP(l) = tmpArray(i, 1)
                    MidleClassEN(l) = StrMidClassENG
                    l = l + 1
                End If
                If RegExp_RoundStartJP.Test(tmpArray(i, 1)) And _
                   RegExp_RoundStartEN.Test(tmpArray(i + 1, 1)) Then
                    StringRoundEnglish = ""
                    ReDim Preserve SubClassJapanese(m)
                    ReDim Preserve SubClass_English(m)
                    For p = 1 To 6
                        StringRoundEnglish = StringRoundEnglish & " " & tmpArray(i + 1, p)
                        StringRoundEnglish = Trim(StringRoundEnglish)
                        If RegExp_RoundExitEN.Test(tmpArray(i + 1, p)) Then Exit For
                    Next p
                    tmpArray(i, 1) = Replace(tmpArray(i, 1), "(", "（")
                    tmpArray(i, 1) = Replace(tmpArray(i, 1), ")", "）")
                    SubClassJapanese(m) = tmpArray(i, 1)
                    StringRoundEnglish = Replace(StringRoundEnglish, "（", "(")
                    StringRoundEnglish = Replace(StringRoundEnglish, "）", ")")
                    SubClass_English(m) = StringRoundEnglish
                    m = m + 1
                End If
            Next i
        Next h
        q = q + 1
    End If
Next tmpSht
Set mySht = Worksheets("Sheet0")
Set myRng = Intersect(mySht.Range("A:H"), mySht.UsedRange)
myAr = myRng
ReDim workArray2(UBound(myAr) - 1, 16)
For i = LBound(workArray2) To UBound(workArray2)
    workArray2(i, 0) = myAr(i + 1, 1)
    workArray2(i, 1) = myAr(i + 1, 2)
    workArray2(i, 2) = myAr(i + 1, 3)
    myAr(i + 1, 4) = Replace(myAr(i + 1, 4), "(", "（")
    myAr(i + 1, 4) = Replace(myAr(i + 1, 4), ")", "）")
    workArray2(i, 6) = myAr(i + 1, 4)
    workArray2(i, 8) = myAr(i + 1, 5)
    workArray2(i, 10) = myAr(i + 1, 6)
    workArray2(i, 12) = myAr(i + 1, 7)
    workArray2(i, 14) = myAr(i + 1, 8)
Next i
Set mySht2 = Worksheets("Result")
Set myRng2 = mySht2.UsedRange
myAr2 = myRng2
For i = LBound(workArray2) To UBound(workArray2)
    For k = LBound(JapaneseClass) To UBound(JapaneseClass)
        If workArray2(i, 2) = JapaneseClass(k) Then
           workArray2(i, 3) = English_Class(k)
        End If
        If workArray2(i, 4) = JapaneseClass(k) Then
           workArray2(i, 5) = English_Class(k)
        End If
        If workArray2(i, 8) = JapaneseClass(k) Then
           workArray2(i, 9) = English_Class(k)
        End If
        If workArray2(i, 12) = JapaneseClass(k) Then
           workArray2(i, 13) = English_Class(k)
        End If
    Next k
    For m = LBound(SubClassJapanese) To UBound(SubClassJapanese)
        If workArray2(i, 6) = SubClassJapanese(m) Then
           workArray2(i, 7) = SubClass_English(m)
        End If
    Next m
    For l = UBound(MidleClassJP) To LBound(MidleClassJP) Step -1
        If workArray2(i, 10) = MidleClassJP(l) Then
           workArray2(i, 11) = MidleClassEN(l)
        End If
    Next l
    For r = LBound(myAr2) To UBound(myAr2)
        If workArray2(i, 0) = myAr2(r, 1) Then
            workArray2(i, 4) = myAr2(r, 5)
            On Error Resume Next
            Select Case True
            Case workArray2(i, 0) >= "10001" And workArray2(i, 0) <= "10278"
                 workArray2(i, 4) = "＜魚類＞"
            Case workArray2(i, 0) >= "10319" And workArray2(i, 0) <= "10341"
                 workArray2(i, 4) = "＜えび・かに類＞"
            Case workArray2(i, 0) >= "10342" And workArray2(i, 0) <= "10362"
                 workArray2(i, 4) = "＜いか・たこ類＞"
            Case workArray2(i, 0) >= "10376" And workArray2(i, 0) <= "10388"
                 workArray2(i, 4) = "＜水産練り製品＞"
            Case workArray2(i, 0) >= "11205" And workArray2(i, 0) <= "11240"
                 workArray2(i, 4) = "＜鳥肉類＞"
            Case workArray2(i, 0) >= "11245" And workArray2(i, 0) <= "11246"
                 workArray2(i, 4) = "＜獣肉類＞"
            Case workArray2(i, 0) >= "11247" And workArray2(i, 0) <= "11247"
                 workArray2(i, 4) = "＜鳥肉類＞"
            Case workArray2(i, 0) >= "13001" And workArray2(i, 0) <= "13050"
                 workArray2(i, 4) = "＜牛乳及び乳製品＞"
            Case workArray2(i, 0) >= "15001" And workArray2(i, 0) <= "15040"
                 workArray2(i, 4) = "＜和生菓子・和半生菓子類＞"
            Case workArray2(i, 0) >= "15041" And workArray2(i, 0) <= "15068"
                 workArray2(i, 4) = "＜和干菓子類＞"
            Case workArray2(i, 0) >= "15069" And workArray2(i, 0) <= "15072"
                 workArray2(i, 4) = "＜菓子パン類＞"
            Case workArray2(i, 0) >= "15073" And workArray2(i, 0) <= "15085"
                 workArray2(i, 4) = "＜ケーキ・ペストリー類＞"
            Case workArray2(i, 0) >= "15086" And workArray2(i, 0) <= "15091"
                 workArray2(i, 4) = "＜デザート菓子類＞"
            Case workArray2(i, 0) >= "15092" And workArray2(i, 0) <= "15100"
                 workArray2(i, 4) = "＜ビスケット類＞"
            Case workArray2(i, 0) >= "15101" And workArray2(i, 0) <= "15104"
                 workArray2(i, 4) = "＜スナック類＞"
            Case workArray2(i, 0) >= "15105" And workArray2(i, 0) <= "15113"
                 workArray2(i, 4) = "＜キャンデー類＞"
            Case workArray2(i, 0) >= "15114" And workArray2(i, 0) <= "15116"
                 workArray2(i, 4) = "＜チョコレート類＞"
            Case workArray2(i, 0) >= "15117" And workArray2(i, 0) <= "15117"
                 workArray2(i, 4) = "＜果実菓子類＞"
            Case workArray2(i, 0) >= "15118" And workArray2(i, 0) <= "15120"
                 workArray2(i, 4) = "＜チューインガム類＞"
            Case workArray2(i, 0) >= "16001" And workArray2(i, 0) <= "16032"
                 workArray2(i, 4) = "＜アルコール飲料類＞"
            Case workArray2(i, 0) >= "16033" And workArray2(i, 0) <= "16044"
                 workArray2(i, 4) = "＜茶類＞"
            Case workArray2(i, 0) >= "16045" And workArray2(i, 0) <= "16049"
                 workArray2(i, 4) = "＜コーヒー・ココア類＞"
            Case workArray2(i, 0) >= "16050" And workArray2(i, 0) <= "16055"
                 workArray2(i, 4) = "＜その他＞"
            Case workArray2(i, 0) >= "17001" And workArray2(i, 0) <= "17054"
                 workArray2(i, 4) = "＜調味料類＞"
            Case workArray2(i, 0) >= "17055" And workArray2(i, 0) <= "17081"
                 workArray2(i, 4) = "＜香辛料類＞"
            Case workArray2(i, 0) >= "17082" And workArray2(i, 0) <= "17084"
                 workArray2(i, 4) = "＜その他＞"
            End Select
            On Error GoTo 0
            workArray2(i, 5) = myAr2(r, 6)
            On Error Resume Next
            Select Case True
            Case workArray2(i, 0) >= "10001" And workArray2(i, 0) <= "10278"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "10319" And workArray2(i, 0) <= "10341"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "10342" And workArray2(i, 0) <= "10362"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "10376" And workArray2(i, 0) <= "10388"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "11205" And workArray2(i, 0) <= "11240"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "11245" And workArray2(i, 0) <= "11246"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "11247" And workArray2(i, 0) <= "11247"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "13001" And workArray2(i, 0) <= "13050"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15001" And workArray2(i, 0) <= "15040"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15041" And workArray2(i, 0) <= "15068"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15069" And workArray2(i, 0) <= "15072"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15073" And workArray2(i, 0) <= "15085"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15086" And workArray2(i, 0) <= "15091"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15092" And workArray2(i, 0) <= "15100"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15101" And workArray2(i, 0) <= "15104"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15105" And workArray2(i, 0) <= "15113"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15114" And workArray2(i, 0) <= "15116"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "15117" And workArray2(i, 0) <= "15117"
                 workArray2(i, 5) = "＜CANDIED FRUITS＞"
            Case workArray2(i, 0) >= "15118" And workArray2(i, 0) <= "15120"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "16001" And workArray2(i, 0) <= "16032"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "16033" And workArray2(i, 0) <= "16044"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "16045" And workArray2(i, 0) <= "16049"
                 workArray2(i, 5) = "COFFEES AND COCOAS>"
            Case workArray2(i, 0) >= "16050" And workArray2(i, 0) <= "16055"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "17001" And workArray2(i, 0) <= "17054"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "17055" And workArray2(i, 0) <= "17081"
                 workArray2(i, 5) = ""
            Case workArray2(i, 0) >= "17082" And workArray2(i, 0) <= "17084"
                 workArray2(i, 5) = ""
            End Select
            On Error GoTo 0
            If workArray2(i, 6) <> "" And _
               workArray2(i, 7) = "" Then
                workArray2(i, 7) = myAr2(r, 8)
            End If
            If workArray2(i, 8) <> "" And _
               workArray2(i, 9) = "" Then
                If myAr2(r, 10) = "" Then
                    workArray2(i, 9) = myAr2(r, 15)
                Else
                    workArray2(i, 9) = myAr2(r, 10)
                End If
            End If
            If workArray2(i, 12) <> "" And _
               workArray2(i, 13) = "" Then
                workArray2(i, 13) = myAr2(r, 15)
            End If
            If workArray2(i, 14) <> "" Then
                workArray2(i, 15) = myAr2(r, 15)
            End If
            workArray2(i, 16) = myAr2(r, 11)
        End If
        Select Case True
            Case workArray2(i, 0) = "14004a"
                workArray2(i, 9) = "Safflower oil"
            Case workArray2(i, 0) = "14011a"
                workArray2(i, 9) = "Sunflower oil"
            Case workArray2(i, 0) = "14011b"
                workArray2(i, 9) = "Sunflower oil"
        End Select
    Next r
Next i
ReDim workArray3(UBound(workArray2), UBound(workArray2, 2))
For i = LBound(workArray3) To UBound(workArray3)
    workArray3(i, 0) = workArray2(i, 0)
    workArray3(i, 1) = workArray2(i, 1)
    workArray3(i, 2) = workArray2(i, 2)
    workArray3(i, 3) = workArray2(i, 4)
    workArray3(i, 4) = workArray2(i, 6)
    workArray3(i, 5) = workArray2(i, 8)
    workArray3(i, 6) = workArray2(i, 10)
    workArray3(i, 7) = workArray2(i, 12)
    workArray3(i, 8) = workArray2(i, 14)
    workArray3(i, 9) = workArray2(i, 3)
    workArray3(i, 10) = workArray2(i, 5)
    workArray3(i, 11) = workArray2(i, 7)
    workArray3(i, 12) = workArray2(i, 16)
    workArray3(i, 13) = workArray2(i, 9)
    workArray3(i, 14) = workArray2(i, 11)
    workArray3(i, 15) = workArray2(i, 13)
    workArray3(i, 16) = workArray2(i, 15)
Next i
Set mySht = Worksheets.Add
With mySht
    .Name = "M_CATEGORY"
    .Range("A1").Value = "ItemNumber"
    .Range("B1").Value = "FoodGroupNumber"
    .Range("C1").Value = "FoodGroupJP"
    .Range("D1").Value = "SubGroupJP"
    .Range("E1").Value = "SubCategoryJP"
    .Range("F1").Value = "MajorCategoryJP"
    .Range("G1").Value = "MediumCategoryJP"
    .Range("H1").Value = "MinorCategoryJP"
    .Range("I1").Value = "DetailsJP"
    .Range("J1").Value = "FoodGroupEN"
    .Range("K1").Value = "SubGroupEN"
    .Range("L1").Value = "SubCategoryEN"
    .Range("M1").Value = "AcademicName"
    .Range("N1").Value = "MajorCategoryEN"
    .Range("O1").Value = "MediumCategoryEN"
    .Range("P1").Value = "MinorCategoryEN"
    .Range("Q1").Value = "DetailsEN"
    .Range("A2:Q1892") = workArray3
End With
Set tmpSht = Nothing
Set tmpRng = Nothing
Set tmpArray = Nothing
Set workArray = Nothing
Set RegExp_Japanese = Nothing
Set RegExp_English = Nothing
Set RegExp_ItemNum = Nothing
Set RegExp_Square_Start = Nothing
Set RegExp_SquareExitEN = Nothing
Set RegExp_RoundStartJP = Nothing
Set RegExp_RoundStartEN = Nothing
Set RegExp_RoundExitEN = Nothing
Erase Item_Number()
Erase JapaneseItem()
Erase EnglishItem()
Erase JapaneseClass()
Erase English_Class()
Erase ItemNumArray()
Erase ItemENGArray()
Erase ClassArrayJP()
Erase ClassArrayEN()
Erase SubClassJapanese()
Erase SubClass_English()
Erase MidleClassJP()
Erase MidleClassEN()
Erase SubClass_JPN()
Erase SubClass_ENG()
Erase workArray2()
Erase workArray3()
Set mySht = Nothing
Set myRng = Nothing
Set myAr = Nothing
Set mySht2 = Nothing
Set myRng2 = Nothing
Set myAr2 = Nothing
End Sub

Function NoCancelArray(ByRef Sh As Variant) As Variant
Dim mySht           As Variant
Dim myRng           As Range
Dim tmpAr           As Variant
Dim i               As Long
Dim j               As Long
Dim RegExpCancel    As Object
Dim RegExp_Exit     As Object
Const StrCancel     As String = "^(1\)|residues)$"
Dim CancelItem()    As String
Dim CancelRow1()    As String
Dim CancelRow2()    As String
Dim myCancelAr()    As String
Dim Cancel_Array()  As String
    Set RegExpCancel = CreateObject("VBScript.RegExp")
    With RegExpCancel
        .Pattern = StrCancel
        .IgnoreCase = True
        .Global = True
    End With
tmpAr = Sh
j = 0
For i = LBound(tmpAr) To UBound(tmpAr)
    If RegExpCancel.Test(tmpAr(i, 1)) Then
        ReDim Preserve CancelItem(j)
        ReDim Preserve CancelRow1(i)
        CancelItem(j) = tmpAr(i, 1)
        CancelRow1(j) = i
        j = j + 1
    End If
Next i
ReDim myCancelAr(UBound(CancelItem), 1)
For j = LBound(myCancelAr) To UBound(myCancelAr)
    myCancelAr(j, 0) = CancelItem(j)
    myCancelAr(j, 1) = CancelRow1(j)
Next j
ReDim Preserve myCancelAr(UBound(myCancelAr), 2)
j = 0
For i = LBound(myCancelAr) To UBound(myCancelAr) - 1
    If myCancelAr(i, 0) = "1)" Then
        If UBound(myCancelAr) >= 2 Then
            If myCancelAr(i + 2, 0) = "residues" Then
                myCancelAr(i, 2) = myCancelAr(i + 2, 1)
            Else
                myCancelAr(i, 2) = myCancelAr(i + 1, 1)
            End If
        Else
            myCancelAr(i, 2) = myCancelAr(i + 1, 1)
        End If
        j = j + 1
    End If
Next i
Erase CancelRow1
j = 0
ReDim CancelRow1(j)
ReDim CancelRow2(j)
CancelRow1(j) = myCancelAr(j, 1)
CancelRow2(j) = myCancelAr(j, 2)
For i = LBound(myCancelAr) + 1 To UBound(myCancelAr)
    If myCancelAr(i, 0) = "1)" And _
       myCancelAr(i - 1, 0) <> "1)" Then
        j = j + 1
        ReDim Preserve CancelRow1(j)
        ReDim Preserve CancelRow2(j)
        CancelRow1(j) = myCancelAr(i, 1)
        CancelRow2(j) = myCancelAr(i, 2)
    End If
Next i
ReDim Cancel_Array(UBound(CancelRow1), 1)
j = 0
For j = LBound(Cancel_Array) To UBound(Cancel_Array)
    Cancel_Array(j, 0) = CancelRow1(j)
    Cancel_Array(j, 1) = CancelRow2(j)
Next j
j = 0
Cancel_Array(j, 0) = 1
Cancel_Array(j, 1) = CancelRow1(j)
For j = LBound(Cancel_Array) + 1 To UBound(Cancel_Array)
    Cancel_Array(j, 0) = CancelRow2(j - 1) + 1
    Cancel_Array(j, 1) = CancelRow1(j) - 1
Next j
NoCancelArray = Cancel_Array
End Function

参照:
日本食品標準成分表2010の食品番号をカテゴリー分類する　その1
日本食品標準成分表2010のcsvファイル