金融数学の問題ですが、割引率rの推計に難儀しています。エクセルのVBA、若しくは専門のソフトなどで素早く解けないでしょうか？

質問

はじめまして。
金融数学ですが、

P=A+(a-r)/(1+r)*A+(b-r)/(1+r)^2*B+(c-r)/(1+r)^3*C+(d-r)/(1+r)^4*D+・・・・・・・+(k-r)/(1+r)^11*K+
(l-r)/r(1+r)^12*L
という式で、今、PとA,B,C,D,・・・・・,K,L及びa,b,c,d,・・・・・,k,lが
解っています。
このときにrを推計したいのですが、どのようにすれば良いでしょうか？エクセルに式を書き、試行錯誤する方法くらいしか思いつきません。が、PとA,B,C,D・・・K,L及びa,b,c,d,・・・・・,k,lのセットが2000サンプルほどあるので、全てを試行錯誤で行うと膨大な時間が掛かってしまいます。
VBAで解く方法、もしくはこういったものを解くソフトウェアの存在など、なにとぞご教示ください。

回答No.13

shinkami

これでよいと思ったことが寝ているうちにより良い方法が見つかるのが常でほって置けなくなります。
しつこくてすみません。

ループから出た後微調整を中間値でなく比例値にしました
これで、シュミレーションのピッチを粗く(0.1%)出来、10倍早くなります。
コーディングを次のように変更してください
(再提示しましたが変更箇所はloopを飛び出した後のみの変更です）

Sub 割引率()
Dim Check
Dim P0, D As Double
Dim P, P1, R, R1 As Double
Dim N, I, J
D = 0.001
If Range("a2") <> "" Then D = Val(Range("a2"))
Range("a2") = D

If Range("b2") <> "" Then I = Val(Range("b2"))
If I < 4 Then I = 4
Range("b2") = I

J = 2000
If Range("c2") = "" Then
Range("c2") = J
Else
J = Val(Range("c2"))
End If
If I > J Then J = I
Range("c2") = J

For N = I To J
Range("d2") = N
R = 0
If Val(Range("A" & N)) > 0 Then
P0 = Val(Range("A" & N))
P = P0 + 1
Check = False
Do
R = R + D
Range("B" & N) = R
P = Val(Range("C" & N))
If R >= 1 Then Check = True
If P <= P0 Then Check = True
Loop Until Check = True

R1 = R - D
Range("B" & N) = R1
P1 = Val(Range("C" & N))
Range("B" & N) = R1 + D * (P0 - P1) / (P - P1)
End If
Next N

End Sub

回答No.12

shinkami

ANo.11の追加です

ワークシートダブルクリックで計算を開始する設定です

マクロ編集画面で
表示メニュー→プロジェクトエクスプローラでプロジェクト-VBAProjectを表示
Sheet1(Sheet1)をダブルクリックで 右にVBA編集画面が表示この画面で
(General)を▼でWorksheetに変更
SelectionChangeをBeforeDoubleClickに変更

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

End Sub

と表示されますこれに割引率を入れて
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
割引率
End Sub

ワークシートの形式(#：値要求 ？VBAで計算表示）

1行目 制度_ 開始行 終了行 処理行 ___ワークシートダブルクリックで計算開始
2行目 ##### ##### #####_ ?????
3行目 株価__ Ｒ _____ 計算値 現在値 1簿価予想 ROE 2簿価予想 ROE 3簿価予想 ROE 4 ‥
4行目 ##### ?????% ?????? ###### ###### #####% ###### #####% ###### #####%

コマンド名不適切でした。適切な名前に変更してください

以上です。

2000年6月に定年退職するまでは、イベント会社でNECオフコンのお守りをしていました。
当時Windows95でMeは重たいという時期でした。

おかげさまで久々に楽しくコーディングに取り組みました。
有難うございました。

回答No.11

shinkami

自分としては完成です

計算に時間が掛かるので、
計算精度:A2・計算開始行:B2・計算終了行:c2・実行中：D2

ANo.９で作成したシートに2行追加しますのでデータ行は4行目からになります

コーディングは次のようになります

Sub 割引率()
Dim Check
Dim P0, D As Double
Dim P, P1, P2, R, R1, R2 As Double
Dim N, I, J
D = 0.001
If Range("a2") <> "" Then D = Val(Range("a2"))
Range("a2") = D

If Range("b2") <> "" Then I = Val(Range("b2"))
If I < 4 Then I = 4
Range("b2") = I

J = 2000
If Range("c2") = "" Then
Range("c2") = J
Else
J = Val(Range("c2"))
End If
If I > J Then J = I
Range("c2") = J

For N = I To J
Range("d2") = N
R = 0
If Val(Range("A" & N)) > 0 Then
P0 = Val(Range("A" & N))
P = P0 + 1
Check = False
Do
R = R + D
Range("B" & N) = R
P = Val(Range("C" & N))
If R >= 1 Then Check = True
If P <= P0 Then Check = True
Loop Until Check = True
R1 = R - D / 2
Range("B" & N) = R1
P1 = Val(Range("C" & N))
R2 = R - D
Range("B" & N) = R2
P2 = Val(Range("C" & N))
If Abs(P0 - P2) > Abs(P0 - P1) Then
Range("B" & N) = R1
End If
If Abs(P0 - P1) > Abs(P0 - P) Then
Range("B" & N) = R
End If
End If
Next N

End Sub

回答No.10

shinkami

VBAに誤りがありました

VBAの7行目の R=0 を FORループ内に入れて次のようになります

Sub 割引率()
Dim Check
Dim P0, D As Double
Dim P, P1, P2, R, R1, R2 As Double
Dim N
D = 0.0001 'Val (Range("h1"))

For N = 2 To 2000
R = 0
If Val(Range("A" & N)) > 0 Then
P0 = Val(Range("A" & N))
P = P0 + 1
Check = False
Do
R = R + D
Range("B" & N) = R
P = Val(Range("C" & N))
If R >= 1 Then Check = True
If P <= P0 Then Check = True
Loop Until Check = True
R1 = R - D / 2
Range("B" & N) = R1
P1 = Val(Range("C" & N))
R2 = R - D
Range("B" & N) = R2
P2 = Val(Range("C" & N))
If Abs(P0 - P2) > Abs(P0 - P1) Then
Range("B" & N) = R1
End If
If Abs(P0 - P1) > Abs(P0 - P) Then
Range("B" & N) = R
End If
End If
Next N

End Sub

回答No.9

shinkami

ほぼ完成です。検証下さい
シート設計変更しました
1行目を見出し
2行目以降がデータ行で1レコード1行としました
1行目の項目名（Ａ～ＡＡ)
_ a b c d e z aa
＿Ｐ 割引率 計算式 Ａ ａ Ｂ ｂ Ｃ ｃ Ｄ ｄ‥‥Ｌ ｌ
C2の計算式は長いですが次のようになります（1行目空白時の処理も含む)
=IF(A2="","",D2+D2*(E2-B2)/(1+B2)+F2*(G2-B2)/(1+B2)^2+H2*(I2-B2)/(1+B2)^3+J2*(K2-B2)/(1+B2)^4+L2*(M2-B2)/(1+B2)^5+N2*(O2-B2)/(1+B2)^6+P2*(Q2-B2)/(1+B2)^7+R2*(S2-B2)/(1+B2)^8+T2*(U2-B2)/(1+B2)^9+V2*(W2-B2)/(1+B2)^10+X2*(Y2-B2)/(1+B2)^11+Z2*(AA2-B2)/(B2*(1+B2)^12))
2行目完成すれば2000行目までコピーしてください

VBAは次のようになります
Sub 割引率()
Dim Check
Dim P0, D As Double
Dim P, P1, P2, R, R1, R2 As Double
Dim N, I
R = 0
D = 0.0001 'Val (Range("h1"))

For N = 2 To 2000
If Val(Range("A" & N)) > 0 Then
P0 = Val(Range("A" & N))
P = P0 + 1
Check = False
Do
R = R + D
Range("B" & N) = R
P = Val(Range("C" & N))
If R >= 1 Then Check = True
If P <= P0 Then Check = True
Loop Until Check = True
R1 = R - D / 2
Range("B" & N) = R1
P1 = Val(Range("C" & N))
R2 = R - D
Range("B" & N) = R2
P2 = Val(Range("C" & N))
If Abs(P0 - P2) > Abs(P0 - P1) Then
Range("B" & N) = R1
End If
If Abs(P0 - P1) > Abs(P0 - P) Then
Range("B" & N) = R
End If
End If
Next N

End Sub

回答No.8

noname#262398

#4のNNAQです。
r=0だとゴールシークは動かないですね。
よく検証せずに投稿してしまい失礼しました。
#6のご回答のように初期値を適当に設定すれば良いですね。
色々やって、初期値によって解が異なるようですが、結構使えそうな気がします（というか、わたしの場合自分でシミュレーションできないのでゴールシークにやらせるしかない）。

演算はゴールシークに任せてそれを自動化させるマクロです。
#5の補足にあるように、サンプルデータは3行×2000セットでA1:L6000の範囲とします。

Sub macro() 'ゴールシーク自動化
Const sets As Integer = 2000 'セット数
Dim i As Long
Dim pformula As String

Application.ScreenUpdating = False
pformula = "=SUM(A2,(A3-N2)/(1+N2)*A2,(B3-N2)/(1+N2)^2*B2,(C3-N2)/(1+N2)^3*C2,(D3-N2)/(1+N2)^4*D2,(E3-N2)/(1+N2)^5*E2,(F3-N2)/(1+N2)^6*F2,(G3-N2)/(1+N2)^7*G2+(H3-N2)/(1+N2)^8*H2,(I3-N2)/(1+N2)^9*I2,(J3-N2)/(1+N2)^10*J2,(K3-N2)/(1+N2)^11*K2,(L3-N2)/N2*(1+N2)^12*L2)"
Range("m2").Formula = pformula
pformula = Replace(pformula, "N2", "N3")
Range("m3").Formula = pformula

For i = 2 To sets * 3 - 1 Step 3
Range("n" & i).Value = 0.00001 'ゴールシークの初期値
Range("n" & i + 1).Value = 0.5 'ゴールシークの初期値
Range("m" & i).GoalSeek Range("a" & i - 1).Value, Range("n" & i)
Range("m" & i + 1).GoalSeek Range("a" & i - 1).Value, Range("n" & i + 1)

Range("m" & i).Resize(2).Copy Range("m" & i + 3)
Range("m" & i).Value = Range("m" & i).Value
Range("m" & i + 1).Value = Range("m" & i + 1).Value
Next i

Application.ScreenUpdating = True
End Sub

N列に r の候補値、M列にその時のP値を、２つずつ出してます。
あくまでもゴールシークの自動化ですので、0.001％単位にしてませんし、
データによっては r が0.5を超えるかもしれません。
時間もかかりそうです。あしからず。

お礼

いえいえ、ｒ＝0ではなくても良い、なんてことは自分が直ぐに気づかなくてはいけない事ですので。

ご教示のゴールシークという機能には瞠目致しました。ツールメニューに入っている基本機能で、こんなに便利なものがあったのに知らなかったとは・・自分の勉強不足を痛感致しました。

VBAを含めて、本などで基礎から学ぶ所存です。

自分なり作ってみたマクロです。
Sub gs1()

Range("AH3").GoalSeek Goal:=266, ChangingCell:=Range("AJ3")
Range("AH4").GoalSeek Goal:=537, ChangingCell:=Range("AJ4")
Range("AH5").GoalSeek Goal:=291, ChangingCell:=Range("AJ5")
Range("AH6").GoalSeek Goal:=246, ChangingCell:=Range("AJ6")
Range("AH7").GoalSeek Goal:=975, ChangingCell:=Range("AJ7")
Range("AH8").GoalSeek Goal:=220, ChangingCell:=Range("AJ8")
Range("AH9").GoalSeek Goal:=7350, ChangingCell:=Range("AJ9")
Range("AH10").GoalSeek Goal:=229, ChangingCell:=Range("AJ10")
・
・
End sub

というマクロを設定しました。数字の羅列であまりに稚拙ですが、上手くワークし、全サンプルのrが数分で求まりました。
セル番やGoalは別シートにコピーし、それと定型を＆でつなげたシンプルなものです。

皆さんにご教示いただいたプロシージャーは、プロシージャーで全てワークすることを確認いたしました。複雑であり、洗練された式なので私の理解を超えていますが、勉強を進めていく過程でその意味を理解できるようになれればと思っており、また別の課題にも応用できそうなので、使用させていただくつもりです。

今回はNNAQさんはじめ、皆さんのお力添えのおかげでなんとか解決することができました。改めまして、皆様に御礼申し上げます。

回答No.7

shinkami

1件だけの処理です。
概要
1行目 Ｐ、中間値、r(答え)
2行目 Ａ～Ｌ
3行目 ａ～ｌ
4行目 項目毎の式

処理
1行目
セルb1：P地入力
セルd1答え(利率) 計算結果
セルf1：=SUM(B4:M4) を入力してください 中間値(対P）
セルH1：ピッチ 入力してください (0.01%)
2行目 セルb2:A‥‥m2：L 入力してください
3行目 セルb3:a‥‥m3：ｌ 入力してください
4行目 式
セルb4：=B2+B2*(B3-$D$1)/(1+$D$1)
セルc4：=C2*(C3-$D$1)/(1+$D$1)^2
セルd4：=D2*(D3-$D$1)/(1+$D$1)^3
‥‥
セルl4：=L2*(L3-$D$1)/(1+$D$1)^11
セルm4：=M2*(M3-$D$1)/($D$1*(1+$D$1)^12)

ここからVBAです
新しいマクロを一つ作り
以下と差し替えてください(コピー&ペースト）

Option Explicit

Sub 割引率計算()
Dim Check
Dim P0, D As Double
Dim P, P1, P2, R, R1, R2 As Double
R = 0
D = Val(Range("h1"))
P0 = Val(Range("b1"))
P = P0 + 1
Check = False
Do
R = R + D
Range("D1") = R
P = Val(Range("F1"))
If R >= 1 Then Check = True
If P <= P0 Then Check = True
Loop Until Check = True
R1 = R - D / 2
Range("D1") = R1
P1 = Val(Range("f1"))
R2 = R - D
Range("D1") = R2
P2 = Val(Range("f1"))
If Abs(P0 - P2) > Abs(P0 - P1) Then
Range("d1") = R1
If Abs(P0 - P1) > Abs(P0 - P) Then
Range("d1") = R
End If
End If
End Sub

ワークシート上にこのマクロを呼び出すコマンドボタンを作成するとより使いやすいです。

2千件分を処理しようとすると、関数定義が必要だと思いますが未体験です。
表の中で計算していますので、fx（P,ピッチ，Ｒ）でいける？
これを機会に関数定義を勉強しますがあてにしないで下さい

お礼

shinkamiさん。たびたびのご回答、感謝の言葉もありません。

ご丁寧な回答にも飽き足らない私の我侭を聞き入れてくださり、プロシージャーの構築までしていただけるとは思ってもおりませんでした。

本当に有難うございます。

私は変数の定義自体よく解っていない状況なので、改めてＶＢＡを一から勉強します。

皆さんの知識の豊富さや、向学心には感心しきりです。

また何かのご縁がありましたら、ご教授のほどよろしくお願いします。

回答No.6

suzusan7

こんにちわぁ

ゴールシークでは［変化させるセル］に最初に入っている値を
初期値として扱います。
従って、最初に0.1あるいは前回のゴールシークの結果を
入れておけば、0による除算は避けられると思います。

ただ、サンプル数が２０００ほどあるのであれば
それだけゴールシークを繰り返す必要があるので
おそらく実用的ではないと思います。

だから、もうひとつ、VBAを使った方法を。
高次方程式を数値的に解く場合、二分法とか
ニュートン法等を用います。下のやつは二分法による解法です。

Option Explicit
Option Base 1
Const e = 10 ^ -5
Function cal(P As Variant, A As Range, B As Range)
Dim r As Variant, c As Variant
Dim H As Variant, L As Variant
Dim HVal As Variant, LVal As Variant
H = 0.5
L = 10 ^ -5
HVal = F(P, A, B, H)
LVal = F(P, A, B, L)
If Sgn(HVal) = Sgn(LVal) Then
cal = "解なし"
Exit Function
End If
Do
r = (H + L) / 2
c = F(P, A, B, r)
If Sgn(c) = Sgn(LVal) Then
L = r
Else
H = r
End If
Loop While (Abs(c) > e)
cal = r
End Function

Function F(P As Variant, A As Variant, B As Variant, r)
F = (1 + B(1)) / (1 + r) * A(1) + (B(2) - r) / (1 + r) ^ 2 * A(2) _
+ (B(3) - r) / (1 + r) ^ 3 * A(3) + (B(4) - r) / (1 + r) ^ 4 * A(4) _
+ (B(5) - r) / (1 + r) ^ 5 * A(5) + (B(6) - r) / (1 + r) ^ 6 * A(6) _
+ (B(7) - r) / (1 + r) ^ 7 * A(7) + (B(8) - r) / (1 + r) ^ 8 * A(8) _
+ (B(9) - r) / (1 + r) ^ 9 * A(9) + (B(10) - r) / (1 + r) ^ 10 * A(10) _
+ (B(11) - r) / (1 + r) ^ 11 * A(11) + (B(12) - r) / (1 + r) ^ 12 / r * A(12) - P
End Function

エクセルでAltキーを押しながらF11を押すとVBAエディタが立ち上がります。
ツールバーから「挿入」-「標準モジュール」を選ぶと、白い画面が出てきます。
そこに上のコードを貼り付けてください。(excel2002)

使い方は、例えば、セルA1にPが、セルA2～L2にA～Lの値が、セルA3～L3にa～lの値が
入力されているとします。
上記のVBAは関数として使用するように作成しておりますので、
どこかのセルに

=cal(A1,A2:L2,A3:L3)

と入力してください。一つ目がPのセル、二つ目がA～Lのセル、三つ目がa～lのセルです。
それで、そのときのrの値を10＾-5～0.5の間で求めます。
三行目のe＝10＾-5というのは右辺と左辺の許容誤差です。
小さくすれば、それだけ、右辺と左辺の差は小さくなるまで計算します。
（その分、計算回数も増えますけど・・・）
あと、エラー処理はしていないので、
A～L、a～lの範囲が少なければたぶんエラーになります。

P、A～L、a～lを１行に並べて、その横に関数を入力して下へコピーをすると
関数の入力の手間も少なくなると思いますよ。

ちなみに具体例では
r=0.023385745
となりました。

お礼

suzusan7さんご回答有難うございます。

高次方程式を解くための二分法、ニュートン法・・確かにそんな方法で解くのが一般的でしたね。お恥ずかしながら記憶の片隅に残っている程度でした。

変化させるセルに適当な数値を入れる方法、参考にさせていただきました。確かに別に０である必要性は無いわけですよね。数字に弱い自分に辟易します・・・・。

非常に手の込んだプロシージャーのご提示、痛み入ります。上手くワークしたみたいです。

VBAというものを使ってみようと思ったのが、数ヶ月前からで、使えば使うほどその奥深さと、便利さに感嘆致します。
とはいえ、ほぼ知識ゼロの状態なので、本などで本格的に勉強をしようと思います。

今回の丁寧な回答、本当に有難うございました。

回答No.5

shinkami

ｒは０～１００％でチェックのピッチは０．１％程度でよろしいですか？
その他の数字2000行分列挙しなければならないでしょうか
（1件分だけ入力セルを設けておき、必要の都度セル内容を書き換える）

Ｐ,Ａ～Ｌ，ａ～ｌの具体的な数値を一つ提示して下さい
1行目 ｐ
2行目 Ａ～Ｌ
3行目 ａ～ｌ

補足

rは0～50％。ピッチは0.001％　つまり、0.00001間隔でお願い出来ますでしょうか？

定数は出来れば2000行分列挙にしたいと考えています。
理想のデザインを言えば、P,A～L、a～ｌの3つの行が2000サンプル、つまり6000列羅列されているシートで、マクロを実行すると一気に2000サンプルのrが求まる・・というものです。
もちろん、難しいようであれば入力セルに都度、P,A～L及びa～lの定数を入力するという方式でも大満足ですの、よろしくご教示願います。

具体例
1行目　P=700
2行目　A=400,B=403,C=407,D=408,E=409,F=,412,G=413,H=418,I=420,J=423,K=426,L=428
3行目　a=0.02,b=0.05,c=0.06,d=0.05,e=0.01,f=0.07,g=0.04,h=0.03,i=0.05,j=0.05,k=0.02,l=0.04

といった感じです。もちろん、シート上では「P＝」「A=」といった文字列は無く、数字だけであり、A列から並列になっています。

以上、なにとぞよろしくお願いします。

蛇足ですが、この式は株価の理論価格を求める式で「残余財産評価モデル」と呼ばれるものだそうです。
Pはとある会社の現在の株価で、Aは現在の一株あたりの純資産簿価、B～LはL期までの将来の予想一株あたり純資産簿価。aは現在の株主資本利益率（ROE）であり、b～ｌはL期までの将来の予想ROEです。
つまり、現在の株価Pは、「その会社の一株あたりの純資産」＋「将来にわたって獲得される異常収益（収益－資金調達コスト）の総和の現在価値（金利を勘案した価値）」によって説明できる、としたモデルです。
今回、私はそのモデルに依拠して、r、つまりその会社にとっての資金調達金利を求めようとしています。
駄文失礼致しました。

回答No.4

noname#262398

VBAではありませんが、エクセルのゴールシークという機能をつかえば、いい線までいけるかもしれません。

1セット目のA,a,B,b・・・K,k,L,lをシートのA1:X1に入力。
AB1セルはr値。
Z1に数式を入力
=A1+(B1-AB1)/(1+AB1)*A1+(D1-AB1)/(1+AB1)^2*C1+・・・・・・・
AA1セルはP値を入力。

この状態だと r=0 のP値が、Z1セルに求められています。

[ツール]メニューの[ゴールシーク]で、
[数式入力セル]　Z1
[目標値]　P値を手入力
[変化させるセル]　AB1
として、OKボタンを押すと結果が出ます。

そして2セット目を2行目に入力して、同じようにします。
数式はフィルドラッグすればよいです。

金融数学とか全く分からないし、ゴールシークの精度も分かりませんので、見当違いだったらご容赦ください。

お礼

実際にやって見たところ、数式の最後に「・・・(l-r)/r(1+r)^12*L」があるので、r=0である場合の数字が#DIV/0（0で除することができないので）となってしまい、ゴールシークが使えないようです。

ちょっと考えればクリアできそうな課題ですが、なかなか難儀しております。

なにかアイデアがありますでしょうか？

補足

いえ、見当違いなどとんでもないです。

的確なアドバイスありがとうございます。ゴールシークという機能は初耳でした。
簡単な実験をしたところ上手くいきそうです。

もうちょっとイジってみないと上手くいくかどうか解りませんが、取り急ぎお礼まで。