Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


29715 / 76732 ←次へ | 前へ→

【52292】元の曲線に対して近似曲線が必ず上になる方法
質問  初心者  - 07/11/5(月) 20:19 -

引用なし
パスワード
   近似曲線を求めるプログラムをもらったのですが、
求める近似曲線が元の曲線よりも必ず高い値になってほしいのです。
どこに手を加えればいいのかがまったくわかりません。
助言よろしくお願いします。

Sub square_least()
Dim Obs(256) As Single '離散点
Dim cons(10), dcon(10) As Single '関数パラメータ
Dim Fobje, xx, Rtmp As Single
Dim Lmat(10, 10), Rmat(10) As Single
Dim l As Single


Dim chk As Single

' 対数近時 f(x)=a*ln(x)+b
cons(1) = 100#
cons(2) = 1#
Nfunc = 2 ' 未知係数の個数

For l = 1 To 256
If (Cells(l, 1) = "") Then
Exit For
 End If
 
Sheets("sheet1").Select

For j = 1 To 256
'chk = Cells(3, j)

If (Cells(l, j) = "") Then ' データ数のチェック
Ndata = j - 1
Exit For
 End If
Obs(j) = Cells(l, j)
Next j

For itr = 1 To 20
'目的関数の作成
Fobje = 0#
For i = 1 To Ndata
xx = i
Fobje = Fobje + (Obs(i) - func(cons, xx)) ^ 2
Next i

'右辺の作成

For j = 1 To Nfunc
Rmat(j) = 0#
Rtmp = 0#
For i = 1 To Ndata
xx = i
Rtmp = Rtmp + dev_f(j, cons, xx) * (Obs(i) - func(cons, xx))
Next i
Rmat(j) = Rtmp
Next j

'左辺の作成
For j = 1 To 10
For i = 1 To 10
Lmat(i, j) = 0#
Next i
Next j

For i = 1 To Nfunc
   For j = 1 To Nfunc
     For k = 1 To Ndata
    xx = k
    Lmat(i, j) = Lmat(i, j) + dev_f(i, cons, xx) * dev_f(j, cons, xx)
    f2 = dev_f(i, cons, xx)
    Next k
    Next j
    Next i
        
    Call gauss(Lmat, Rmat, dcon, Nfunc, 10)

    bcoef = 0.5
  
    For i = 1 To Nfunc
    cons(i) = cons(i) + bcoef * dcon(i)
    Next i
  Sheets("sheet1").Select
  Next itr
  For i = 1 To Ndata
  Sheets("sheet3").Select
  Cells(l, i) = cons(1) * Log(i) + cons(2)
  Sheets("sheet1").Select
  Next i
 Next l

End Sub

1 hits

【52292】元の曲線に対して近似曲線が必ず上になる方法 初心者 07/11/5(月) 20:19 質問

29715 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free