[第77期]编写VBA代码解方程

sunya_0529

为了答题，恶补了初等数论相关的知识，楼主出的题可真不是一般的难。

做了一个自定义函数，=getxy(61)和=getxy(73)可解。

1. Function getxy(d As Integer) As String
   
2. Application.Volatile False
   
3. Dim p(0 To 999) As Integer, q(0 To 999) As Integer, a(0 To 999) As Integer, i%, j%, k%, x As Double, y As Double, z As Double
   
4. p(0) = 0
   
5. q(0) = 1
   
6. a(0) = Int(d ^ 0.5)
   
7. If a(0) ^ 2 = d Then
   
8.   getxy = "无解" 'd为完全平方数时无解
   
9. Else
   
10.   Do
    
11.     i = i + 1
    
12.     p(i) = a(i - 1) * q(i - 1) - p(i - 1)
    
13.     q(i) = (d - p(i) ^ 2) / q(i - 1)
    
14.     a(i) = Int((a(0) + p(i)) / q(i)) '计算√d的连分数
    
15.   Loop While a(i) <> 2 * a(0)
    
16.   
    
17.   If i Mod 2 = 1 Then '如果循环节是奇数的话，扩充连分数数组到第二个循环节
    
18.     For j = 1 To i
    
19.       a(i + j) = a(j)
    
20.     Next
    
21.     i = i * 2
    
22.   End If
    
23.   
    
24.   x = 1
    
25.   y = a(i - 1)
    
26.   For k = i - 2 To 1 Step -1 '根据连分数推算对应的渐近分数
    
27.     z = x
    
28.     x = y
    
29.     y = a(k) * y + z
    
30.   Next
    
31.   x = a(0) * y + x
    
32.   getxy = "(" & x & "," & y & ")"
    
33. End If
    
34. End Function

复制代码

[ 本帖最后由 sunya_0529 于 2011-7-30 03:06 编辑 ]

wkbu

Sub 题目1()
Dim x As Double
Dim y As Double
For y = 1 To 60000000
MySqr = Int(Sqr(73 * y * y))
For x = MySqr To MySqr + 1
If 73 * y * y = x * x - 1 Then
Cells(1, 9) = "题目一答案："
Cells(1, 10) = "x=" & x
Cells(1, 11) = "y=" & y
Exit Sub
End If
Next
Next
End Sub

Sub 题目2()
Dim x As Double
Dim y As Double
For y = 1 To 600000000
MySqr = Int(Sqr(61 * y * y))
For x = MySqr To MySqr + 1
If 61 * y * y = x * x - 1 Then
Cells(2, 9) = "题目二答案："
Cells(2, 10) = "x=" & x
Cells(2, 11) = "y=" & y
Exit Sub
End If
Next
Next
End Sub

wangg913

题目结束，请勿修改，以利版主总结、评分。

长安布衣

我测试过了，可能无解
由于计算机的误差，要限定误差值为很小很小，这样速度很慢，穷举到很大数据都无解
有时，将误差设定较小，计算的结果根据最末位计算，是不对的，可惜今天没有将文件带来，改天贴上

wkbu

应该有解，不用解方程的算法，只用穷举法也可行。我自己在22楼的算法运算时间约20秒，期待狼版给出好的答案。

cathy408

学习了~~~~~~

cumulonimbus

学习了。

smartsoft

wangg913 发表于 2011-8-15 13:45
题目结束，请勿修改，以利版主总结、评分。

有没有晚了？

1. Sub Q1()
   
2. Dim x As Double: Dim y1 As Double: Dim y2 As Double
   
3. Dim i&
   
4. 
   
5. i = 1
   
6. Do
   
7.     x = 73 * i
   
8.     y1 = Sqr((x - 2) * x / 73)
   
9.     y2 = Sqr(x * (x + 2) / 73)
   
10.     If Int(y1) = y1 Or Int(y2) = y2 Then Exit Do
    
11.     i = i + 1
    
12. Loop
    
13. If Int(y1) = y1 Then x = x - 1: y = y1 Else x = x + 1: y = y2
    
14. Debug.Print x, y
    
15. End Sub
    
16. 
    
17. Sub Q2()
    
18. Dim x As Double: Dim y1 As Double: Dim y2 As Double
    
19. Dim i&
    
20. 
    
21. i = 1
    
22. Do
    
23.     x = 61 * i
    
24.     y1 = Sqr((x - 2) * x / 61)
    
25.     y2 = Sqr(x * (x + 2) / 61)
    
26.     If Int(y1) = y1 Or Int(y2) = y2 Then Exit Do
    
27.     i = i + 1
    
28. Loop
    
29. If Int(y1) = y1 Then x = x - 1: y = y1 Else x = x + 1: y = y2
    
30. Debug.Print x, y
    
31. End Sub
    

复制代码

Q1：2281249       267000
Q2：851361202     109005632

fangjianp

今天查看了一下,居然此题不了了之,开创了先例!

sunya_0529

fangjianp 发表于 2013-7-26 16:21
今天查看了一下,居然此题不了了之,开创了先例!

要不版主你给总结下，结帖算了:)