タグ: 食品成分

　ある施設の1年間で提供した食事のレシピの食品成分のテキストファイルから，データベースに取り込むための前処置としてデータを第1正規形に整形する EXCEL VBA コードです．個人的な備忘録です．

　94行目以降の関数 Count_Record は，アクティブシートをループして必要なレコード数を計測する関数です．104行目以降で料理名の数（B列），119行目以降で食品名の数（C列）に注目しています．サブルーチン TransportFromTxtToCSV から呼び出して，動的配列の要素数を後で決定するのに用います．

Option Explicit

Sub LoopProcedure()
    Dim Sh  As Worksheet
    For Each Sh In Worksheets
        If Sh.Name Like "Sheet" & "*" Then
            Call TransportFromTxtToCSV(Sh)
        End If
    Next Sh
End Sub

Sub TransportFromTxtToCSV()
    Dim mySht               As Worksheet
    Dim myRng               As Range
    Dim myAr                As Variant
    Dim RecAr()             As String
    Dim i                   As Long
    Dim j                   As Long
    Dim k                   As Long
    Dim Date_Serving_Meal   As Date
    Dim Menu_Name           As String
    Dim tmpStart            As Long
    Dim Meal_Time           As String
    Dim Dish                As String
    Dim RecordNumber        As Long
    
    set mysht = sh
    RecordNumber = Count_Record(mySht)
    ReDim RecAr(RecordNumber - 1, 51)
    Set myRng = mySht.UsedRange
    myAr = myRng
    k = 0
    Date_Serving_Meal = "2011/1/1"
    Menu_Name = myAr(1, 11) & myAr(1, 12) & myAr(1, 13)
    tmpStart = InStr(Menu_Name, ")")
    Menu_Name = Mid(Menu_Name, tmpStart + 1)
    Meal_Time = "朝食"
    For i = LBound(myAr) To UBound(myAr)
        
        Select Case True
            Case myAr(i, 2) = "合      計"
                Date_Serving_Meal = DateAdd("d", 1, Date_Serving_Meal)
            Case myAr(i, 2) = "《朝食》"
                Meal_Time = "朝食"
            Case myAr(i, 2) = "《昼食》"
                Meal_Time = "昼食"
            Case myAr(i, 2) = "《夕食》"
                Meal_Time = "夕食"
            Case myAr(i, 2) = "小      計"
            Case myAr(i, 2) = "^e12【献立"
            Case myAr(i, 2) Like "動蛋比" & "*"
            Case myAr(i, 2) = "・・・・・・・・・・"
            Case myAr(i, 2) = "料理名"
            Case myAr(i, 2) = ""
            Case Else
                Dish = myAr(i, 2)
        End Select
        
        Select Case True
            Case myAr(i, 3) = "・・・・・・・・・・・"
            Case myAr(i, 3) Like "EN比" & "*"
            Case myAr(i, 3) = "食品名"
            Case myAr(i, 3) Like "一覧表】 ^e11" & "*"
            Case myAr(i, 3) = ""
            Case Else
                RecAr(k, 0) = Date_Serving_Meal
                RecAr(k, 1) = Menu_Name
                RecAr(k, 2) = Meal_Time
                RecAr(k, 3) = Dish
                RecAr(k, 4) = myAr(i, 3)
                For j = 5 To 22
                    RecAr(k, j) = myAr(i, j - 1)
                Next j
                For j = 23 To 39
                    RecAr(k, j) = myAr(i + 1, j - 18)
                Next j
                For j = 40 To 51
                    RecAr(k, j) = myAr(i + 2, j - 35)
                Next j
                k = k + 1
        End Select
    Next i
    Set mySht = Worksheets.Add
    With mySht
        .Name = Menu_Name
        .Range(Cells(1, 1), Cells(RecordNumber, 52)) = RecAr
    End With
    
    Set mySht = Nothing
    Set myRng = Nothing
    Erase RecAr
End Sub

Function Count_Record(ByRef Sh As Worksheet) As Long    
    Dim mySht       As Worksheet
    Dim myAr        As Variant
    Dim i           As Long
    Dim j           As Long
    Dim k           As Long
    Set mySht = Sh
    myAr = mySht.UsedRange
    j = 0
    k = 0
    For i = LBound(myAr) To UBound(myAr)
        Select Case True
            Case myAr(i, 2) = "合      計"
            Case myAr(i, 2) = "小      計"
            Case myAr(i, 2) = "《朝食》"
            Case myAr(i, 2) = "《昼食》"
            Case myAr(i, 2) = "《夕食》"
            Case myAr(i, 2) = "^e12【献立"
            Case myAr(i, 2) Like "動蛋比" & "*"
            Case myAr(i, 2) = "・・・・・・・・・・"
            Case myAr(i, 2) = "料理名"
            Case myAr(i, 2) = ""
            Case Else
                j = j + 1
        End Select
        Select Case True
            Case myAr(i, 3) = "・・・・・・・・・・・"
            Case myAr(i, 3) Like "EN比" & "*"
            Case myAr(i, 3) = "食品名"
            Case myAr(i, 3) Like "一覧表】 ^e11" & "*"
            Case myAr(i, 3) = ""
            Case Else
                k = k + 1
        End Select
    Next i
    Count_Record = k
End Function