VBA 減量のためのカロリー計算

ちょっと最近太りぎみなのでそろろそマジでダイエットでもしようかと思い立ったところ、世の中には種々様々なダイエット法が存在していて、一体どうすれば良いのか混乱する。

ただ基本的には、シンプルにこういう式で表すことができる。
　摂取エネルギー > 消費エネルギー →太る
　摂取エネルギー < 消費エネルギー →痩せる
　摂取エネルギー = 消費エネルギー →維持

それで、変なダイエット法に当たるくらいなら、ちゃんとカロリー計算した方が良いなと思って、マクロにしてみた。

データを集める

厚労省の資料から

WHOとかの研究データをもとに書かれてるので信頼できる。
https://www.mhlw.go.jp/file/05-Shingikai-10901000-Kenkoukyoku-Soumuka/0000083871.pdf

P54 3─2─3．目標とする BMI の範囲

ここには、統計データから最も死亡率の低いBMI値が掲載されている。
対象年齢ごとに目標BMIが異なるが、全年齢をカバーするのが21.5～24.93であることが分かった。

よって、その中間値 23.215 を目標に定めることにした。

達成後も21.5~24.93からはみ出ないように23.215に向けて調整し続ければ良い。

P56・P57

ここにとても重要なことが書かれている。

なお、脂肪細胞 1 gが7 kcal を有すると仮定すれば、100 kcal/日のエネルギー摂取量の減少は14.3 g/日の体重減少、つまり、5.21 kg/年の体重減少が期待できるが、上記のようにそうはならない。これは、主として、体重の減少に伴ってエネルギー消費量も減少するためであると考えられる。体重の変化（減少）は徐々に起こるため、それに呼応してエネルギー消費量も徐々に減少する。そのため、時間経過に対する体重の減少率は徐々に緩徐になり、やがて、体重は減少しなくなる。
～中略～

つまり、体重変化の度に、必要エネルギー量は計算し直さないといけないのだ。

P65 4─2．基礎代謝基準値

ここには基礎代謝を求める計算式が書かれている。

年齢、性別、身長、体重を用いた下記の日本人の基礎代謝量の推定式 170）は、BMI が 30 kg/m2 程度までならば体重による系統誤差を生じないことが示されており 35）、BMI が 25～29.9 kg/m2 の肥満者では、この推定式で基礎代謝量の推定が可能である。
基礎代謝（kcal/日）＝〔0.0481×体重（kg）＋0.0234×身長（cm）－0.0138×年齢（歳）－定数（男性：
0.4235、女性：0.9708）〕×1000/4.186

P67～69

ここには活動レベルⅠ～Ⅲの定義と年齢を考慮した活動量がある。
ただ成人してからはそんなに変わらないので、Ⅰが1.5、Ⅱが1.75、Ⅲが2と覚えればよさげ。
私はデスクワーク中心なので、意識的に運動しない日は1.5、運動する日は1.75ということにした。

P70

最後に、推定エネルギー必要量（kcal/日）＝基礎代謝量（kcal/日）×身体活動レベルという計算式が出てくる。
これでPDFから取得する材料はおしまい。

その他の情報

ググってみると、脂肪1キロあたりのカロリーは7200kcalとのこと。
また、痩せるスピードとしては1月で1キロくらいがベストらしい。
つまり30日で7200kcalのマイナスなので、推定エネルギー必要量よりも1日あたり240kcal少ない食事量にすれば、1キロ/月ペースで痩せることができる。

コーディング

シートモジュール

まずシミュレーション結果を表示させるシートのオブジェクト名をSimulationSheetに変更する。
f:id:t-hom:20191012195622p:plain

コードは次のとおり。

Private Cursor As Long
Private Enum Col
    日付 = 1
    想定体重
    活動レベル
    摂取カロリー目安
    BMI
End Enum
Private Const HEADER_ROW = 1

Sub Init()
    Me.Cells.Delete
    Cursor = HEADER_ROW + 1
    Me.Cells(HEADER_ROW, Col.日付) = "日付"
    Me.Cells(HEADER_ROW, Col.想定体重) = "想定体重"
    Me.Cells(HEADER_ROW, Col.活動レベル) = "活動レベル"
    Me.Cells(HEADER_ROW, Col.摂取カロリー目安) = "摂取カロリー目安"
    Me.Cells(HEADER_ROW, Col.BMI) = "BMI"
End Sub

Sub WriteRecord(day, weight, activity_level, cal_intake, bmi_)
    Me.Cells(Cursor, Col.日付) = day
    Me.Cells(Cursor, Col.想定体重) = weight
    Me.Cells(Cursor, Col.活動レベル) = activity_level
    Me.Cells(Cursor, Col.摂取カロリー目安) = cal_intake
    Me.Cells(Cursor, Col.BMI) = bmi_
    Cursor = Cursor + 1
End Sub

標準モジュール

標準モジュールは次のとおり。

'パラメーター(自分のデータを入れる)
Const 初期体重 = 85
Const 身長 = 176.8
Const 運動頻度 = 3  ' 日に1回
Const 減量目標 = 30 ' 日ごとに1キロ
Const 性別 = "男"
Const 開始日 = #10/12/2019#

'固定係数(基本さわらない)
Const 体重係数 = 0.0481
Const 身長係数 = 0.0234
Const 年齢係数 = 0.0138
Const 男性係数 = 0.4235
Const 女性係数 = 0.9708
Const 理想BMI = 23.215
Const 脂肪1に対するCal = 7200

Sub Main()
    Dim 体重 As Double: 体重 = 初期体重
    Dim 経過日数 As Long: 経過日数 = 0
    SimulationSheet.Init
    Do
        Dim 身体活動レベル As Double: 身体活動レベル _
            = IIf(経過日数 Mod 運動頻度 = 0, 1.75, 1.5)
        
        Dim 体重維持エネルギー As Double: 体重維持エネルギー _
            = 基礎代謝(体重, 身長, #6/28/1984#, 性別) * 身体活動レベル
            
        Dim BMI As Double: BMI = 体重 / (身長 / 100) ^ 2
        SimulationSheet.WriteRecord _
            day:=開始日 + 経過日数, _
            weight:=Round(体重, 1), _
            activity_level:=身体活動レベル, _
            cal_intake:=Round(体重維持エネルギー - (脂肪1に対するCal / 減量目標)), _
            bmi_:=Round(BMI, 1)

        体重 = 体重 - (1 / 減量目標)
        経過日数 = 経過日数 + 1
    Loop While BMI > 理想BMI
End Sub

Function 基礎代謝(体重 As Double, 身長 As Double, 生年月日 As Date, 性別 As String)
    Dim 年齢 As Double
    年齢 = CLng(Date - 生年月日) / 365
    
    Dim 性別補正 As Double
    Select Case 性別
        Case "男"
            性別補正 = 男性係数
        Case "女"
            性別補正 = 女性係数
    End Select
    
    基礎代謝 = ((体重 * 体重係数) + (身長 * 身長係数) - (年齢 * 年齢係数) - 性別補正) * 1000 / 4.186
End Function