練習問題５ - プログラム倉庫

Function rev(ax, price As Single) As Single
Dim n As Single
Dim a As Single
Dim cost As Single
Dim r1 As Single
cost = 1
r1 = 0
For n = 1 To 10
a = ax(n)
q = prefer(a, price)
r1 = r1 + price * q - cost * q
Next
rev = r1
End Function


Function prefer(a As Single, price As Single) As Single
Dim q As Single
Dim maxu As Single
Dim maxq As Single
Dim u1 As Single
maxu = u(a, 0)
maxq = 0
For q = 1 To 50
u1 = u(a, q) - price * q
If u1 > maxu Then maxq = q
If u1 > maxu Then maxu = u1
Next
prefer = maxq
End Function

Function u(a As Single, q As Single) As Single
Dim b As Single
b = 1
u = a * q - b * q ^ 2
End Function
Private Sub Command1_Click()
Dim price As Single
Dim cost As Single
Dim q As Single
Dim ps As Single
Dim p1 As Single
Dim p2 As Single
Dim h As Single
Dim rs As Single
Dim r1 As Single
Dim r2 As Single
Dim a As Single
Dim ax(1 To 10) As Single
Dim x(1 To 10) As Single
For m = 1 To 10
ax(m) = 100 - m
Next
h = 1
ps = 12
price = ps
rs = rev(ax, price)
Debug.Print rs
t = 0
Do Until t > 100
p1 = ps + h
p2 = ps - h
price = p1
r1 = rev(ax, price)
price = p2
r2 = rev(ax, price)
If r1 > rs Then ps = p1
If r1 > rs Then rs = r1
If r2 > rs Then ps = p2
If r2 > rs Then rs = r2
If px = ps Then t = 1000
px = ps
t = t + 1
Loop
price = ps
Debug.Print price
For m = 1 To 10
a = ax(m)
x(m) = prefer(a, price)
Debug.Print m, x(m)
Next

End Sub