改訂版『身体活動のメッツ表』からテキストを抽出する

　国立健康・栄養研究所が2011年版『身体活動のメッツ表』を改訂しました．下記リンクはPDFファイルですが，そのままでは使いにくいためEXCELでテキスト情報を抽出しました．2012年7月3日，国立健康・栄養研究所に抽出したテキストファイルを公開して良いか問い合わせました．

身体活動のメッツ表

1. PDFファイルを開き，全てを選択してコピーします．

2. EXCELの新規ブックを作成し，テキストファイルウィザードを使用して貼り付けます．この際，テキストファイルウィザードの2番目のタブで区切り文字の全てのチェックを外して下さい．3番目のタブでは列のデータ形式を『文字列』に変更して下さい．

3. ‘Alt’ キーと ‘F11’ キーを押下して VBE を起動し，標準モジュールを挿入して下記コードを実行して下さい．

Option Explicit
Sub METS()
Dim mySht   As Worksheet
Dim myRng   As Range
Dim myAr    As Variant
Dim i       As Long
Dim j       As Long
Dim myReg   As Object
Dim myMatches   As Object
Dim myMatch     As Object
Const strReg    As String = "^[0-9]{5}$"
Dim CODE()  As String
Dim METS()  As Single
Dim MajorHeading()  As String
Dim SpecificActivities()    As String
Dim myArray()   As Variant
Set myReg = CreateObject("VBScript.RegExp")
With myReg
    .Pattern = strReg
    .IgnoreCase = True
    .Global = True
End With

Set mySht = ActiveSheet
Set myRng = mySht.UsedRange
myAr = myRng
j = 0
For i = LBound(myAr) To UBound(myAr)
    If myReg.Test(myAr(i, 1)) Then
        Set myMatches = myReg.Execute(myAr(i, 1))
        ReDim Preserve CODE(j)
        ReDim Preserve METS(j)
        ReDim Preserve MajorHeading(j)
        ReDim Preserve SpecificActivities(j)
        CODE(j) = myAr(i, 1)
        METS(j) = myAr(i + 1, 1)
        MajorHeading(j) = myAr(i + 2, 1)
        SpecificActivities(j) = myAr(i + 3, 1)
        j = j + 1
    End If
Next i
ReDim myArray(j, 3)
For j = LBound(myArray) To UBound(myArray) - 1
    myArray(j, 0) = CODE(j)
    myArray(j, 1) = METS(j)
    myArray(j, 2) = MajorHeading(j)
    myArray(j, 3) = SpecificActivities(j)
Next j
Set mySht = Worksheets.Add
mySht.Range("A1").Value = "CODE"
mySht.Range("B1").Value = "METS"
mySht.Range("C1").Value = "MajorHeading"
mySht.Range("D1").Value = "SpecificActivities"
mySht.Range("A2:D827") = myArray
End Sub