エクセルVBAで献立自動化、栄養士さんお助けツール、PFCバランスグラフ

PFCバランスグラフの作成
まとめ
全コード解説
ダウンロード

PFCバランスグラフの作成

PFCバランスグラフとは

食事の摂取カロリーに対して三大栄養素がどのくらいの割合で摂取されたか表しているグラフです

■三大栄養素は蛋白質（P)、脂質（F)、炭水化物（C)です。

■摂取総エネルギーに対する三大栄養素がそれぞれ理想的な摂取割合は次の通りです

蛋白質　13～20％

脂質　20～30％

炭水化物　50～65％

と言われています下図の場合はP=20%、F=30％、C=65%　に規定して計算しています

このパーセンテージは調整できるようにしています（それぞれの項目のセル値を修正すればOKです）

■三大栄養素の各摂取割合を計算するには、それぞれの摂取グラム数値をエネルギー換算値に変換する必要があります。

ここでは（下図）では蛋白質＝ｇ当り4kcal、脂質＝ｇ当り9kcal、炭水化物＝ｇ当り4kcal　としています（アトウォーター係数というやつで決まっているらしいですよ）

■グラフのイメージは下図のような感じです。円の中に三角形が描かれ、中心から伸びる直線が三大栄養素の摂取割合を示しています。PFCバランスグラフとして最もオーソドックスなイメージだと思います。

Excelシート（下図）の下半分にあるのは、ある献立のレシピを構成する食品の使用量に対応した栄養素の摂取値を表にまとめたものです。この表の最下段の栄養素合計欄のセルの値をグラフの3本の直線の長さを求めるために参照しています。

■円の半径が摂取したエネルギーの総量を表し、三大栄養素の各直線の長さを表し、摂取した栄養素のエネルギー換算値の総エネルギーに対する割合が表現されています。各直線の終点を更に直線で結ぶと各終点を頂点とする三角形になります

ここでは、設定項目で各20%、30％、65％と規定していますので、実際の栄養素摂取量の総エネルギー値に対する割合が20%、30％、65％であれば、円に内接する正三角形になります。つまり円に達していなければ摂取不足で、円を突き抜けていれば摂取過多とみることができます。

下図では脂質の摂取量を誇張（P列 32行めセルに10加算）して作図したのでグラフでも脂質直線が円を突き抜けています。

■①は円Topの座標、②は円Leftの座標です。③は円の半径を表しています。つまり、円の中心座標は（ｘ＝②＋③　,　ｙ＝①+③）となり、この中心座標がすべての他の図形（シェイプ）描画の基礎となっています。

ピクセル座標

■図形を構成している各種の直線はActiveSheet.Shapes.AddLine()を使って描画します。カッコの中には直線の始点と終点の座標が入ります。

下図の場合、座標は　ActiveSheet.Shapes.AddLine(x1, y1, x2, y2)の様に指定します

ｘ、ｙはそれぞれピクセル値で入力します。（始点、終点のピクセル値を知る必要があります）

摂取栄養値をグラフの長さに変換する

グラフで栄養値の変化をとらえるには、栄養値を線分の長さに変換する必要があります。

摂取データをグラフに表示するために必要なデータはシート４の7行目の表にまとめてあります。

これ以降は、脂質の摂取データを使って、グラフの長さに変換する方法を考えてみます。

脂質の基準対比は30％が標準ですから
脂質摂取値のエネルギー換算値　÷　総エネルギー値　×　１００　＝　30％であれば、標準の10摂取量だという意味です。これはちょうど円の半径に当たります。

グラフの作成については単位がピクセルで計算します。
ここではエクセルシートの左端から250ピクセル、上端から30ピクセルの位置（座標）に半径100ピクセルの円を描画する設定になっています。栄養素の摂取値をグラフに表すにはこの摂取値をピクセルに変換した座標情報にする必要があります。■そして、栄養値の数値を直線の長さで表現するためにエクセルの図形描画のために用意されているシェイプを使用します。シェイプの書式はActiveSheet.Shapes.AddLine(始点X, 始点Y, 終点X, 終点Y)です。このステートメントで直線の始点と終点の座標位置を引数に指定することになっています。

■具体的に計算してみます。

ここ（上図）では、総エネルギー値は445.06Kcal

脂質の摂取合計栄養値22.18　×　換算係数9kcal　＝　換算摂取エネルギー199.69kcal

総エネルギー値445.06kcal　×　基準割合30％　＝　基準エネルギー値は133.52Kcal

そして、円の半径は長さを100ピクセルとしているので、

摂取エネルギーの長さ（ピクセル）　＝　半径　÷　基準エネルギー値　×　換算摂取エネルギー

下図①の斜辺長さ＝100÷133.52×199.69＝149.55（ピクセルは整数なので結果は150となります。）

■先ほどのActiveSheet.Shapes.AddLineの引数では始点と終点の座標を指定するので、上の計算で①の長さが分かっているので、あとは⑥の長さが分かれば終点座標を指定できるようになります。

■栄養素直線は3本で円を3等分して配置するので直線と隣り合う直線の角度は120度ですから

■上図のように①を斜辺とする直角三角形は①と⑦の角度は60度、①と⑥の角度は30度となりますから特別な30度、60度、90度の直角三角形の場合、下図のように三平方の定理を適用して他の辺の長さを計算することができます。

■①の直線の長さが分かっているので三平方の定理から⑦＝①÷２、⑥＝⑦√３　で計算できます。

⑦　＝　150　÷　2　＝　75

⑥　＝　75　×　√３　＝　129.9　≒　130

■つまり、①の直線の終点座標は（ｘ＝②＋⑤＋⑥　,　ｙ＝③＋④＋⑦　）から

x　＝　250　＋　100　＋　130　＝　480

ｙ　＝　30　＋　100　＋　75　＝　205

■終点座標のｘｙ（480　,　205）となります。

円の中心座標ｘ＝②＋⑤＝350、ｙ＝③＋④＝130　で固定されます。

■始点座標のｘｙ（350　,　130）となります。

これを.Shapes.AddLine(始点X, 始点Y, 終点X, 終点Y)に当てはめると

.Shapes.AddLine((350,　130,　480,　205)で脂質の線を引くことができます。

注意！Shapes.AddLineは実行するつどラインを新しく追加するメソッドです。実行するたび追加で描画するのではなく、一度作ったオブジェクトを使いまわすことができれば効率がいいと思いますが選択したオブジェクトを再設定する場合、座標の指定するプロパティーが無いみたいです。つまり座標指定でラインを引く場合はShapes.AddLineを使うしかないみたいです。（私の探し方が悪いのでしょうか？何か方法があるかもしれませんが、今はこれしか思いつきません）結果、このオブジェクトが何度も作成しないために、最初に作ったオブジェクトに名前を付けておき次にまた追加するとき前回作った名前のオブジェクトを消去する方法にしました。

まとめ

このプログラムの肝は三平方の定理なので、これを中心に解説してきました。

あまりうまく説明できてないかもしれません。纏まりない内容で、初心者向けではないかもしれません。このグラフは自分もVBA覚え始めのころ仕事上で必要に駆られて作ったものです。何かのヒントをプログラムで表現して、それが実現できた時の喜びは、まさしく、エクセルを制御してやった！！。でした。

全コード解説

■グラフ作成する処理を呼び出す。プロシージャでは前半で変数宣言してグラフの作成位置を確認し、表の合計データを収集してます。収集したデータを一番最後の一行の引数にしてグラフ描画処理を呼び出しています。

Public Sub gurafukousinn()
'hankeidataitiはシート2の朝食等カテゴリーごとの円図形の位置情報
'goukeiitiは　シート１のカテゴリーごとの集計合計行を示す数値

Dim sitennX As Single
Dim sitennY As Single

Dim hankei As Single
Dim ennleft As Single
Dim enntop As Single

Dim E As Integer
Dim P As Single
Dim F As Single
Dim C As Single

'グラフ位置
hankei = Sheet5.Cells(3, 2)
ennleft = Sheet5.Cells(4, 2)
enntop = Sheet5.Cells(5, 2)
'栄養価データ取得
E = Sheet5.Cells(37, 11)
P = Sheet5.Cells(37, 14)
F = Sheet5.Cells(37, 16)
C = Sheet5.Cells(37, 18)
'熱量換算計算
P = P * Sheet5.Range("C8")  '4kcal
F = F * Sheet5.Range("C9")  '9kcal
C = C * Sheet5.Range("C10")  '4kcal

'円の中心点（長さの始点）のｘ座標
sitennX = ennleft + hankei
'円の中心点（長さの始点）のｙ座標
sitennY = enntop + hankei

'====================================================================
Call zukeibyouga("sougou", hankei, ennleft, enntop, sitennX, sitennY, E, P, F, C)



End Sub

■次に引数で受け取ったデータを基にして円や３本の直線を作成しますが、17～29行目で前回に作成した図形があるときはそれを削除しています（作成したときに名前を付けているので名前があるときは作成済みとして削除します）

■次に円を描きますが、円はLeft値とTop値と半径値が分かればそれだけで描画できますから問題ありません。

■次に3本の直線（タンパク質、脂質、炭水化物）を描きます。前段までに直線シェイプを引きにはその座標を知る必要があると書いてきました。ので、引数でもらっている各栄養値を更にファンクション関数の引数にして（40行、50行、59行目の各行で）syuutenXY(E, P, “p”, hankei, ennleft, enntop)を呼び出して座標を受け取っています。

Private Sub zukeibyouga(kategori As String, hankei As Single, _
                        ennleft As Single, enntop As Single, _
                        sitennX As Single, sitennY As Single, _
                        E As Integer, P As Single, F As Single, C As Single)
Dim enn As Variant
Dim pro As Variant
Dim fat As Variant
Dim crb As Variant
'Dim sacl As Variant
Dim ketu1 As Variant
Dim ketu2 As Variant
Dim ketu3 As Variant

'データ取り出し


'図形があるかチェックしてあれば削除する
    Dim zukei As Shape
    For Each zukei In Sheet5.Shapes
        If zukei.Name = "enn_" & kategori _
            Or zukei.Name = "pro_" & kategori _
            Or zukei.Name = "fat_" & kategori _
            Or zukei.Name = "crb_" & kategori _
            Or zukei.Name = "ketu1_" & kategori _
            Or zukei.Name = "ketu2_" & kategori _
            Or zukei.Name = "ketu3_" & kategori Then
            zukei.Delete
        End If
    Next


'円の描画
Set enn = ActiveSheet.Shapes.AddShape(msoShapeOval, ennleft, enntop, hankei * 2, hankei * 2) 'shapes(2) asa円
enn.Fill.ForeColor.RGB = RGB(230, 230, 250) 'ラベンダー
enn.Name = "enn_" & kategori

'プロテイン長さを描画
If E = 0 Then Exit Sub
Dim syuuten As Variant
syuuten = syuutenXY(E, P, "p", hankei, ennleft, enntop)
PsyuutenX = syuuten(0)
PsyuutenY = syuuten(1)
Set pro = ActiveSheet.Shapes.AddLine(sitennX, sitennY, PsyuutenX, PsyuutenY) 'shapes(3)　プロテイン
'直線の色、太さ指定
pro.line.ForeColor.RGB = RGB(0, 255, 0) 'green
pro.line.Weight = 1
pro.Name = "pro_" & kategori

'脂質
syuuten = syuutenXY(E, F, "f", hankei, ennleft, enntop)
FsyuutenX = syuuten(0)
FsyuutenY = syuuten(1)
Set fat = ActiveSheet.Shapes.AddLine(sitennX, sitennY, FsyuutenX, FsyuutenY) 'shapes(4)　ファット
fat.line.ForeColor.RGB = RGB(0, 0, 255) 'blue
fat.line.Weight = 1
fat.Name = "fat_" & kategori

'炭水化物
syuuten = syuutenXY(E, C, "c", hankei, ennleft, enntop)
CsyuutenX = syuuten(0)
CsyuutenY = syuuten(1)
Set crb = ActiveSheet.Shapes.AddLine(sitennX, sitennY, CsyuutenX, CsyuutenY) 'shapes(5)　カーボン
crb.line.ForeColor.RGB = RGB(255, 165, 0) 'orange
crb.line.Weight = 1
crb.Name = "crb_" & kategori

'各頂点を結線して三角形を描画
Set ketu1 = ActiveSheet.Shapes.AddLine(PsyuutenX, PsyuutenY, FsyuutenX, FsyuutenY) '結線１
ketu1.Name = "ketu1_" & kategori
Set ketu2 = ActiveSheet.Shapes.AddLine(FsyuutenX, FsyuutenY, CsyuutenX, CsyuutenY) '結線2
ketu2.Name = "ketu2_" & kategori
Set ketu3 = ActiveSheet.Shapes.AddLine(CsyuutenX, CsyuutenY, PsyuutenX, PsyuutenY) '結線3
ketu3.Name = "ketu3_" & kategori

'ｐｆｃ吹き出し項目の位置決め
If kategori = "sougou" Then
    Call fukidasiiti(PsyuutenX - 30, PsyuutenY - 30, FsyuutenX + 10, FsyuutenY, CsyuutenX - 70, CsyuutenY + 10)
End If

End Sub

■下図のファンクション関数では3本の直線の各座標値を計算して返しています。内、蛋白質は円の中心から垂直に上にまっすぐ引いた直線なので長さが分かっただけで描画できます。脂質は前段までに説明しているように、三平方の定理を使って座標計算した結果を使って描画します。炭水化物も脂質と同様ですが、脂質は円の中心に対して右側に伸びるのに対して炭水化物は左方向へ伸びているので、横方向座標のｘ値は計算結果をマイナスしなければならないことに注意してください（脂質40行目は、＋プラス、炭水化物50行目は、ーマイナス）

Public Function syuutenXY(E As Integer, eiyouti As Single, kategori As String _
                            , hankei As Single, ennleft As Single, enntop As Single) As Variant
'栄養価の長さの終点座標を求めて配列にして返す（配列（０）がx座標（１）がy座標）
'第一引数　E=総エネルギー
'第二引数　eiyouti 現在の実際の栄養数値
'第三引数　kategori P=蛋白質　F=脂質　C=炭水化物

Dim xy(1) As Variant

Dim Pnagasa As Single
Dim Fnagasa As Single
Dim Cnagasa As Single

'栄養価量の換算熱量
Dim kanP As Single
Dim kanF As Single
Dim kanC As Single
Dim kijunP As Single
Dim kijunF As Single
Dim kijunC As Single

Select Case kategori
    Case "P", "p"
        kanP = eiyouti  '現在熱量換算値
        kijunP = E * Sheet5.Cells(8, 2)    '蛋白質２０％ 基準栄養換算熱量
        Pnagasa = kanP * hankei / kijunP
        '--------------------------------------
        xy(0) = ennleft + hankei 'x座標
        xy(1) = enntop + (hankei - Pnagasa) 'y座標
        If xy(1) < 0 Then
            xy(1) = 0
        End If
        'ファンクションに返す
        syuutenXY = xy
    Case "F", "f"
        kanF = eiyouti
        kijunF = E * Sheet5.Cells(9, 2)    '脂質　３０％
        Fnagasa = kanF * hankei / kijunF
        '------------------------円の中心から右側なので半径にプラス--------------
        xy(0) = ennleft + (hankei + (Fnagasa / 2 * Sqr(3))) 'x
        xy(1) = enntop + hankei + (Fnagasa / 2) 'y
        'ファンクションに返す
        syuutenXY = xy

    Case "C", "c"
        kanC = eiyouti
        kijunC = E * Sheet5.Cells(10, 2)   '炭水化物６５％
        Cnagasa = kanC * hankei / kijunC
        '-------------------------円の中心から左側なので半径からマイナス------------
        xy(0) = ennleft + (hankei - (Cnagasa / 2 * Sqr(3))) 'x
        xy(1) = enntop + hankei + (Cnagasa / 2) 'y
        'ファンクションに返す
        syuutenXY = xy
End Select

End Function

■この処理はおまけで三本の直線の栄養素名を吹き出しで表示しているだけです。

この吹き出しはあらかじめ手動で作成し名前を付けているので。間違って吹き出しを削除したときはエラーになります。

エラーにならないようにするには円や直線と同様にこの吹き出しもプログラムで作成するようにしたらいいですね。とりあえずはこのままで。

Public Sub fukidasiiti(pX As Variant, pY As Variant, fX As Variant, fY As Variant, cX As Variant, cY As Variant)
'ｐｆｃ吹き出し項目の位置決め
With Sheet5.Shapes("吹き出しP")
    .Left = pX
    .Top = pY
End With
With Sheet5.Shapes("吹き出しF")
    .Left = fX
    .Top = fY
End With
With Sheet5.Shapes("吹き出しC")
    .Left = cX
    .Top = cY
End With
'円を最背面に
Sheet5.Shapes("enn_sougou").ZOrder msoSendToBack

End Sub