第６講　Functionプロシージャ

第４話　円の面積を求めるFuncitonプロシージャ

円の一部の面積を求めるFuncitonプロシージャ
Private Sub CommandButton1_Click()

　　Dim r As Double, a As Double, b As Double, k As Long

　　r = Cells(6, 2)
　　a = Cells(7, 2)
　　b = Cells(8, 2)
　　k = Cells(9, 2)

　　Cells(10, 2) = f(r, a, b, k)
　　Cells(11, 2) = 4 * f(1, 0, 1, k)

End Sub


Function f(r As Double, a As Double, b As Double, k As Long)

　　Dim w As Double, d As Double

　　w = 0
　　d = (b - a) / k
　　For i = 0 To k
　　　　w = w + d * Sqr(r * r - (a + i * d) * (a + i * d))
　　Next

　　f = w

End Function


Private Sub CommandButton2_Click()

　　Columns("B").Select
　　Selection.ClearContents
　　Cells(1, 1).Select

End Sub
実行画面例



因みに、このマクロによる分割個数とπの近似値の表を載せておくと、

円周率は、3.14159265ですからたった１０００００００個に分割するだけで、かなり正確な値が求められることがわかります。

さて、次の課題です。Functionプロシージャによって、
『成績一覧表マクロ』
Private Sub CommandButton1_Click()

　　f1　'各生徒の合計点・平均点の計算
　　f2　'各教科等の合計点・平均点の計算
　　f3　'各生徒の合否判定
　　f4　'各生徒の講評
　　f5　'各生徒の最高点の算出
　　f6　'各生徒の最低点の算出
　　f7　'各教科と合計・平均の最高点の算出
　　f8　'各教科と合計・平均の最低点の算出

End Sub

Sub f1()

　　Dim i As Byte, j As Byte

　　'生徒の合計点・平均点の計算
　　For i = 1 To 40
　　　　w = 0
　　　　For j = 1 To 5
　　　　　　w = w + Cells(6 + i, 1 + j)
　　　　Next
　　　　Cells(6 + i, 7) = w
　　　　Cells(6 + i, 8) = w / 5
　　Next

End Sub

Sub f2()

　　Dim i As Byte, j As Byte

　　'各教科等の合計点・平均点の計算
　　For i = 1 To 7
　　　　w = 0
　　　　For j = 1 To 40
　　　　　　w = w + Cells(6 + j, 1 + i)
　　　　Next
　　　　Cells(47, 1 + i) = w
　　　　Cells(48, 1 + i) = w / 40
　　Next

End Sub

Sub f3()

　　Dim i As Byte, j As Byte

　　'各生徒の合否判定　
　　For i = 1 To 40
　　　　If Cells(6 + i, 7) >= 300 Then
　　　　　　Cells(6 + i, 11) = "合格"
　　　　End If
　　　　If Cells(6 + i, 7) < 300 Then
　　　　　　Cells(6 + i, 11) = "不合格"
　　　　End If
　　Next

End Sub

Sub f4()

　　Dim i As Byte, j As Byte

　　'各生徒の講評
　　For i = 1 To 40
　　　　If Cells(6 + i, 7) >= 350 Then
　　　　　　Cells(6 + i, 12) = "あなたはかなり優秀です。"
　　　　End If
　　　　If Cells(6 + i, 7) < 350 And Cells(6 + i, 7) >= 300 Then
　　　　　　Cells(6 + i, 12) = "おめでとう。"
　　　　End If
　　　　If Cells(6 + i, 7) < 300 And Cells(6 + i, 7) >= 200 Then
　　　　　　Cells(6 + i, 12) = "合格まで後一歩です。"
　　　　End If
　　　　If Cells(6 + i, 7) < 200 Then
　　　　　　Cells(6 + i, 12) = "かなりのがんばりが必要です。"
　　　　End If
　　Next

End Sub

Sub f5()

　　Dim i As Byte, j As Byte

　　'各生徒の最高点の算出
　　Dim max As Integer
　　For i = 1 To 40
　　　　max = 0
　　　　For j = 1 To 5
　　　　　　If Cells(6 + i, 1 + j) >= max Then max = Cells(6 + i, 1 + j)
　　　　Next
　　　　Cells(6 + i, 9) = max
　　Next

End Sub

Sub f6()

　　Dim i As Byte, j As Byte

　　'各生徒の最低点の算出
　　Dim min As Integer
　　For i = 1 To 40
　　　　min = 100
　　　　For j = 1 To 5
　　　　　　If Cells(6 + i, 1 + j) < min Then min = Cells(6 + i, 1 + j)
　　　　Next
　　　　Cells(6 + i, 10) = min
　　Next

End Sub

Sub f7()

　　Dim i As Byte, j As Byte

　　'各教科と合計・平均の最高点の算出
　　For i = 1 To 7
　　　　max = 0
　　　　For j = 1 To 40
　　　　　　If Cells(6 + j, 1 + i) > max Then max = Cells(6 + j, 1 + i)
　　　　Next
　　　　Cells(49, 1 + i) = max
　　Next

End Sub

Sub f8()

　　Dim i As Byte, j As Byte

　　'各教科と合計・平均の最低点の算出
　　For i = 1 To 7
　　　　min = 500
　　　　For j = 1 To 40
　　　　　　If Cells(6 + j, 1 + i) < min Then min = Cells(6 + j, 1 + i)
　　　　Next
　　　　Cells(50, 1 + i) = min
　　Next

End Sub



Private Sub CommandButton2_Click()

　　Range("B7:L50").Select
　　Selection.ClearContents
　　Cells(1, 1).Select

End Sub

Private Sub CommandButton3_Click()

　　Dim i As Byte, j As Byte

　For i = 1 To 40
　　　For j = 1 To 5
　　　　　Cells(6 + i, 1 + j) = Int(100 * Rnd())
　　　Next
　　Next

End Sub
をより見通しのよいものに変更します。

横の合計を求めるFuncitonプロシージャg1、縦の合計を求めるFunctionプロシージャg2、
横の最高点を求めるFuncitonプロシージャg3、横の最低点を求めるFunctionプロシージャg4
縦の最高点を求めるFunctionプロシージャg5、縦の最低点を求めるFunctionプロシージャg6
用意して書き換えてください。

第３話へ　第５話へ

vc++講義へ
vb講義へ
ＶＢ講義基礎へ
初心者のための世界で一番わかりやすいVisual C++入門基礎講座へ
初心者のための世界で一番わかりやすいVisual Basic入門基礎講座へ

数学研究室に戻る