In this article, I’d like to describe how to fix the text file of the food composition of the diet recipes, which a facility have provided for one year, to the first normal form in order to insert into database.
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