btinc.jp シェアウェア・フリーウェアTop
 デモ   クラス仕様   クラスを使う   ダウンロード 

まず、オブジェクトを作成し、InitSetメソッドでポイント座標を与えます。
そのあとで、プロパティ、メソッドで必要な情報を取得します。

具体的には下記のデモプログラムVBAソースコードをご覧ください。

フォームモジュール UserForm1
'==================================== ' デモフォーム 2009-12-05 ' 2010-02-14改訂 '==================================== Option Explicit Private Sub CommandButton1_Click() Dim mes As String mes = DrawCurve() If Len(mes) > 0 Then MsgBox mes End Sub Private Sub CommandButton2_Click() With ThisWorkbook.Worksheets("デモ") .Range(.Cells(3, 2), .Cells(6002, 3)).ClearContents End With End Sub Private Sub UserForm_Initialize() Label1.Caption = "ポイントの座標を入力して「計算実行」ボタンをクリックしてください。" & vbLf & _ "6000個まで入力できます。ただし、X座標が重複しているとエラーになります。" & vbLf & _ vbLf & _ "フォームは開いたままでもシート操作はできます。" End Sub
標準モジュール Module1
'============================================ ' CurveFit デモ ' 2009-12-14 ' 2010-02-14 改訂 '============================================ Option Explicit Public Sub フォームを開く() UserForm1.Show vbModeless End Sub Public Function DrawCurve() As String Dim ret As String Dim pX() As Double Dim pY() As Double Dim pCount As Integer Dim i As Integer Dim rc As Integer Dim tRow As Long Dim tCol As Long Dim s As Integer Dim j As Integer Dim x As Double Dim co As Variant Dim jisu As Integer With ThisWorkbook.Worksheets("デモ") 'ポイントのX座標に重複があるとエラーになるため、 'ソートして重複のないことを確認しつつ配列にセットする .Range("B3:C6002").Sort Key1:=.Range("B3"), _ Order1:=xlAscending, _ Header:=xlNo, _ OrderCustom:=1, _ MatchCase:=False, _ Orientation:=xlTopToBottom, _ SortMethod:=xlPinYin pCount = .Cells(2, 1).Value If pCount > 2 Then ReDim pX(0 To pCount - 1) ReDim pY(0 To pCount - 1) For i = 0 To pCount - 1 If IsEmpty(.Cells(i + 3, 2)) Then pCount = i If i < 2 Then ret = "ポイント不足" Exit For Else pX(i) = .Cells(i + 3, 2).Value pY(i) = .Cells(i + 3, 3).Value If i > 0 Then If pX(i) = pX(i - 1) Then '重複 ret = "X座標が重複している" Exit For End If End If End If Next i '''''''''''''''''''''''''''''''''''''''''''''''''''''''' If Len(ret) = 0 Then 'CurveFitオブジェクトを作成し、ポイント座標を与える Dim curve As New CurveFit rc = curve.InitSet(pCount, pX, pY) If rc > 0 Then '補間式係数をシートに書き出す .Range(.Cells(3, 5), .Cells(6002, 8)).ClearContents For s = 0 To curve.pointsCount - 2 tRow = s + 3 For j = 0 To 3 tCol = j + 5 .Cells(tRow, tCol).Value = curve.SplineCoefs(j, s) Next j Next s 'Y値を計算してグラフデータを作成する For i = 0 To 50 tRow = i + 33 x = .Cells(tRow, 11).Value .Cells(tRow, 12).Value = curve.YValSpline(x) Next i '最小二乗法による近似多項式を求める jisu = 6 co = curve.GetLSMCoefs(jisu) If Not IsEmpty(co) Then For j = 0 To jisu .Cells(3, 9 + j).Value = co(j) Next j End If Else Select Case rc Case -1 ret = "ポイント数不正" Case -2 ret = "ポイント座標配列の基底はゼロでなければならない" Case -3 ret = "ポイント数に対し配列サイズが小さい" Case -4 ret = "X座標が重複している" Case -5 ret = "スプライン補間失敗" Case Else ret = "原因不明" End Select End If 'CurveFitオブジェクト破棄 Set curve = Nothing End If Else ret = "ポイント不足" End If End With DrawCurve = ret End Function

ページ先頭