Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2188|回复: 9

[VBA] 用VBA解欧拉计划题目(80)--平方根数字展开

[复制链接]
发表于 2017-12-5 20:28 | 显示全部楼层 |阅读模式
第80题:平方根数字展开
众所周知,如果一个自然数的平方根不是整数,那么就一定是无理数。这样的平方根的小数部分是无限不循环的。
2的平方根为1.41421356237309504880…,它的小数点后一百位数字的和是475。
对于前一百个自然数,求所有无理数平方根小数点后一百位数字的总和。

发表于 2017-12-6 16:27 | 显示全部楼层
求正确开根号的代码,我自己写的算到根号2小数点后面第29位就开始错了。
  1. Sub aaa()
  2. Dim n, s$, s1$, m&, tmp, cnt&
  3. n = 2
  4. s1 = s1 & Int(Sqr(n))
  5. n = (n - s1 * s1) * 100
  6. Do
  7.   tmp = s1 * 20
  8.   m = Int(n / tmp)
  9.   m = Int(n / (tmp + m))
  10.   s1 = s1 & m
  11.   cnt = cnt + m
  12.   n = (n - m * (tmp + m)) * 100
  13. Loop Until Len(s1) = 101
  14. MsgBox s1
  15. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2017-12-6 16:35 | 显示全部楼层
用了一堆大数计算,+,-,*,都用到了
开方的思路是网上找的,不是很理解。

  1. Function LongSqr(n, digits)   '对于n,返回其小数长度为digits的平方根
  2.     Dim a$, b$
  3.     p = Int(Sqr(n))
  4.     ws = digits + Len(p)  '整数+小数的总位数
  5.     limit = 10 ^ (ws + 1)
  6.     a = 5 * n
  7.     b = 5
  8.     Do While Val(b) < limit
  9.         If Val(a) >= Val(b) Then
  10.             a = LargeMinus(a, b)
  11.             b = LargeSum(b, 10)
  12.         Else
  13.             a = LongMult(a, 100)
  14.             b = Left(b, Len(b) - 1) & "05"
  15.         End If
  16.     Loop
  17.     LongSqr = Left(b, Len(b) - 2)
  18.     LongSqr = p & "." & Mid(LongSqr, Len(p) + 1)
  19. End Function

  20. Public Function LargeSum(aa, bb)   '大数a+大数b
  21.     a = aa: b = bb
  22.     If Len(a) < Len(b) Then x = a: a = b: b = x
  23.     b = String(Len(a) - Len(b), "0") & b
  24.     ReDim arr(Len(a))
  25.     For k = Len(a) To 1 Step -1
  26.         s = Val(Mid(a, k, 1)) + Val(Mid(b, k, 1))
  27.         arr(k) = arr(k) + s
  28.         If arr(k) >= 10 Then
  29.             arr(k) = arr(k) - 10
  30.             arr(k - 1) = arr(k - 1) + 1
  31.         End If
  32.     Next
  33.     LargeSum = Join(arr, "")
  34. End Function

  35. Public Function LargeMinus(aa, bb)   '大数a-大数b
  36.     a = aa: b = bb
  37.     If Val(a) < Val(b) Then dw = "-": x = a: a = b: b = x
  38.     b = String(Len(a) - Len(b), "0") & b
  39.     ReDim arr(Len(a))
  40.     For k = 1 To Len(a)
  41.         arr(k) = Val(Mid(a, k, 1))
  42.     Next
  43.     For k = Len(a) To 1 Step -1
  44.         s = arr(k) - Val(Mid(b, k, 1))
  45.         If s >= 0 Then
  46.             arr(k) = s
  47.         Else
  48.             arr(k) = s + 10
  49.             arr(k - 1) = arr(k - 1) - 1
  50.         End If
  51.     Next
  52.     For k = 1 To Len(a)
  53.         If Val(arr(k)) > 0 Then Exit For
  54.     Next
  55.     For i = k To Len(a)
  56.         LargeMinus = LargeMinus & arr(i)
  57.     Next
  58.     LargeMinus = dw & LargeMinus
  59. End Function
  60. Public Function LargeMult(a, b)  '计算任意多位数的a,乘以单位数b
  61.     la = Len(a)
  62.     ReDim arr(la)
  63.     For i = la To 1 Step -1
  64.         arr(i) = arr(i) + Val(Mid(a, i, 1)) * b
  65.         If arr(i) >= 10 Then
  66.             arr(i - 1) = arr(i - 1) + Int(arr(i) / 10)
  67.             arr(i) = arr(i) - Int(arr(i) / 10) * 10
  68.         End If
  69.     Next
  70.     LargeMult = Join(arr, "")
  71. End Function

  72. Public Function LongMult(a, b)  '计算任意多位数的a,乘以多位数b
  73.     la = Len(a): lb = Len(b)
  74.     ReDim brr(1 To lb)
  75.     For k = lb To 1 Step -1
  76.         bb = Mid(b, k, 1)
  77.         brr(k) = LargeMult(a, bb) & String(lb - k, "0")
  78.     Next
  79.     LongMult = brr(1)
  80.     For i = 2 To lb
  81.         LongMult = LargeSum(LongMult, brr(i))
  82.     Next
  83. End Function
复制代码
回复

使用道具 举报

 楼主| 发表于 2017-12-6 16:37 | 显示全部楼层
longsqr(2,100)=
1.4142135623730950488016887242096980785696718753769480731766797379907324784621070388503875343276415727
回复

使用道具 举报

发表于 2017-12-6 16:57 | 显示全部楼层
这个也是要网上找答案了。
回复

使用道具 举报

发表于 2017-12-6 17:05 | 显示全部楼层
我推测不是算法的错误,而是大数计算产生的问题,而对我大数处理确实不太懂,网上还找到了牛顿迭代法,比这个还要简单,但是需要对每次产生的小数进行下次计算,所以碰到同样的问题。
回复

使用道具 举报

发表于 2017-12-7 21:31 | 显示全部楼层
本帖最后由 香川群子 于 2017-12-7 21:47 编辑
grf1973 发表于 2017-12-6 16:37
longsqr(2,100)=
1.414213562373095048801688724209698078569671875376948073176679737990732478462107038 ...

经确认,开方的最大有效位数=307(因为Val最大1E+308)

研究了一下,一些大数位计算可以省略或简化,不影响计算。

唯一需要保留的是大数位减法。
这个原来的计算方法也没有我的快,所以也进行了改良。(使用CDec十进制大数位计算)

最终结果,比原来的计算快了10-20倍。

  1. Function LongSqr(n, digits)   '对于n,返回其小数长度为digits的平方根
  2.     Dim a$, b$, i&, limit, m&, p, tms#
  3.     tms = Timer
  4.    
  5.     p = Int(Sqr(n))

  6.     m = digits + Len(p)  '整数+小数的总位数<1E+308
  7.     If m > 306 Then m = 306
  8.     limit = 10 ^ (m + 1) '1E+307

  9.     a = 5 * n
  10.     b = 5
  11.     Do While Val(b) < limit
  12.         If Val(a) >= Val(b) Then
  13.             a = LargeMinus(a, b)
  14.             
  15. '            b = LargeSum(b, 10) 'b+10
  16.             b = 0 & b
  17.             For i = Len(b) - 1 To 1 Step -1
  18.                 If Mid(b, i, 1) < 9 Then Mid(b, i, 1) = Mid(b, i, 1) + 1: Exit For Else Mid(b, i, 1) = 0
  19.             Next
  20.             If Left(b, 1) = 0 Then b = Mid(b, 2)
  21.         Else
  22. '            a = LongMult(a, 100)
  23.             a = a & "00" 'a*100
  24.             b = Left(b, Len(b) - 1) & "05"
  25.         End If
  26.     Loop
  27.     Debug.Print Format(Timer - tms, "0.000s"); n; digits
  28.    
  29.     LongSqr = Left(b, Len(b) - 2)
  30.     LongSqr = p & "." & Mid(LongSqr, Len(p) + 1)
  31. End Function
  32. Function LargeMinus$(aa$, bb$)   '大数a-大数b
  33.     Dim a$, b$, i&, n0&, n1&, r$, s$, t, t0

  34.     a = aa: b = bb
  35.     If Val(a) < Val(b) Then Stop: LargeMinus = "-" & LargeMinus(b, a): Exit Function

  36.     n1 = Len(a): n0 = Len(b)
  37.     r = String(28, "0"): t0 = CDec(1 & r)

  38.     For i = 1 To (n0 - 1) \ 28
  39.         t = t0 + t + CDec(Mid(a, n1 - i * 28 + 1, 28)) - CDec(Mid(b, n0 - i * 28 + 1, 28))
  40.         s = Right(r & t, 28) & s: If Len(t) > 28 Then t = 0 Else t = -1
  41.     Next

  42.     t = t - CDec(Left(b, n0 - i * 28 + 28))
  43.     For i = i To (n1 - 1) \ 28
  44.         t = t0 + t + CDec(Mid(a, n1 - i * 28 + 1, 28))
  45.         If Len(t) > 28 Then
  46.             LargeMinus = Left(a, n1 - i * 28) & Right(t, 28) & s: Exit Function
  47.         Else
  48.             s = Right(r & t, 28) & s: t = -1
  49.         End If
  50.     Next
  51.     s = (CDec(Left(a, n1 - i * 28 + 28)) + t) & s

  52.     For i = 1 To Len(s) - 1
  53.         If Mid(s, i, 1) > 0 Then Exit For
  54.     Next
  55.     LargeMinus = Mid(s, i)
  56. End Function
复制代码


回复

使用道具 举报

发表于 2017-12-7 21:42 | 显示全部楼层
1.945s
40727

1-100中,除去1,4,9,16,25,36,49,64,81,100这几个完全平方数以外,
剩余90个数的开方值的小数点后100位的数字的总和=40727,各数字的平均值=4.525
回复

使用道具 举报

发表于 2017-12-14 21:24 | 显示全部楼层
我自己用牛顿迭代法写成开方代码了,但是验算结果,只有小数点后长度>150位的才会更有效率。

而且是位数越大差异越大。
回复

使用道具 举报

发表于 2017-12-18 19:43 | 显示全部楼层
对3楼的算术开方算法,进行了改良,
即,不是每次增加1位小数的计算,而是每一次增加尽可能多的小数位数。

考虑到代码的复杂度不大幅增加的情况下,较为可靠的是每次计算8位小数。
因为一开始的计算误差会比较大,所以不能一下子取太多位数。
只能2位2位计算几次,然后开始大幅度进行计算。

这样可以比原先的速度要快40-60倍了。
如果计算小数点后几千乃至几万位,也可以了。


代码如下:
  1. Option Explicit
  2. Sub test2() 'by kagawa 2017/12/17
  3.     Dim d&, i&, j&, n&, r&, s$, s2$, t#, p&, tms#
  4.     tms = Timer
  5. '    s = "1.41421356237309504880168872420969807856967187537694807317667973799073247846210703885038753432764157"
  6.    
  7.     p = 1000 '取小数点后1千位
  8.    For n = 2 To 200 '计算2到200
  9.         t = Sqr(n)
  10.         If t <> Int(t) Then '非完全平方数时
  11.             
  12.             s = LongSqr2(n, p) '按指定小数位开方
  13.             
  14.             DoEvents
  15.    
  16.             s2 = LongMult(s, s) '大数相乘验算
  17.             j = InStr(s2, ".") '小数点位置
  18.             For i = j + 1 To Len(s2)
  19.                 If Mid(s2, i, 1) <> 9 Then Exit For '验证实际有效小数位
  20.             Next
  21. '            Debug.Print n; p; i - j
  22.         End If
  23.     Next
  24.     Debug.Print Format(Timer - tms, " 0.000s")
  25. End Sub
  26. Function LongSqr2(ByVal n&, ByVal p&)
  27.     '对于任意正整数n、 返回其小数长度p的平方根 计算单位d
  28.     Dim a$, b$, b1, d2&, i&, j&, j1&, j2&, t&, t1$, t2$, tms#
  29. '    tms = Timer
  30.    
  31.     d = 8: d2 = d * 2 '每次增量计算8位
  32.    
  33.     b1 = Int(Sqr(n) * 10 ^ 5) '利用自带函数开方取开方值整数部分
  34.    
  35.     a = (n * 10 ^ 10 - b1 * b1) * 5 & String(4, "0") '第一次计算直接扣除开方整数部分 然后扩大5倍好算
  36.     b = b1 & String(2 + 1, "0") 'b*10 扩大10倍相当于2*b*5 可以简化计算
  37.     j1 = Len(a): j2 = Len(b)
  38.     For i = -2 To Int(p / d)  '循环直至小数位足够
  39.         If j2 > 18 Then j = 18 Else j = j2 '取有效位数计算'
  40.         t = Int(Val(Left(a, j1 - j2 + j)) / Val(Left(b, j))) '取当前有效个位商t
  41.         If t Then                   '  b'=b*10^d*10
  42.             t1 = LargeSum(b, t * 5) '=(b'+t*5)=(b*10^d*10+t*5)
  43.             t2 = LargeMult(t1, t) '=(b'+t*5)*t=(b*10^d*10+t*5)*t =(2*b*10^d*t+t*t)*5

  44.             a = LongMinus(a, t2) 'a'=(N-b^2)*5*10^d2-[b^2*5*10^d2+(b*10^d*10+t*5)*t]
  45.             b = LargeSum(b, t & "0") '=b'+t*10=b*10^d*10+t*10=b"*10
  46.         End If
  47.         a = a & String(IIf(i < 0, 4, d2), "0"): j1 = Len(a)
  48.         b = b & String(IIf(i < 0, 2, d), "0"): j2 = Len(b)
  49.     Next
  50.    
  51. '    Debug.Print Format(Timer - tms, "0.000s"); n; p; d
  52.     b1 = Int(Sqr(n))
  53.     LongSqr2 = b1 & "." & Mid(b, Len(b1) + 1, p) '按指定小数位输出结果
  54. End Function
  55. Function LargeSum$(ByVal a$, ByVal b$)  '大数a+小数b(<16位)
  56.     Dim i&, t$, t1$, t2$
  57.     If Len(a) <= Len(b) Then
  58.         LargeSum = Val(a) + Val(b)
  59.     Else
  60.         t1 = Left(a, Len(a) - Len(b)) '截取a前面超出b的部分不用计算
  61.         t2 = CDec(Right(a, Len(b))) + CDec(b) '仅计算尾部对齐b的部分
  62.         If Len(t2) > Len(b) Then '如果有进位
  63.             t = Left(t2, 1) '截取进位数字t
  64.             For i = Len(t1) To 1 Step -1 '倒序检查拼接
  65.                 If Mid(t1, i, 1) + t > 9 Then '超9时需进位
  66.                     Mid(t1, i, 1) = 0: t = 1 '本位归零、进位=1
  67.                 Else '不超9时直接相加然后退出
  68.                     Mid(t1, i, 1) = Mid(t1, i, 1) + t: Exit For
  69.                 End If
  70.             Next
  71.             If i = 0 Then t1 = 1 & t1 '检查至头部仍需进位时前面+1
  72.         End If
  73.         LargeSum = t1 & t2
  74.     End If
  75. End Function
  76. Function LongMinus$(ByVal a$, ByVal b$)   '大数a-大数b
  77.     Dim i&, n0&, n1&, r$, s$, t, t0
  78.    
  79.     n1 = Len(a): n0 = Len(b)
  80.     If n1 < 29 Then LongMinus = CDec(a) - CDec(b): Exit Function
  81.     r = String(28, "0"): t0 = CDec(1 & r)
  82.     t = 0
  83.     For i = 1 To (n0 - 1) \ 28
  84.         t = t0 + t + CDec(Mid(a, n1 - i * 28 + 1, 28)) - CDec(Mid(b, n0 - i * 28 + 1, 28))
  85.         s = Right(r & t, 28) & s: If Len(t) > 28 Then t = 0 Else t = -1
  86.     Next
  87.    
  88.     t = t - CDec(Left(b, n0 - i * 28 + 28))
  89.     For i = i To (n1 - 1) \ 28
  90.         t = t0 + t + CDec(Mid(a, n1 - i * 28 + 1, 28))
  91.         If Len(t) > 28 Then
  92.             LongMinus = Left(a, n1 - i * 28) & Right(t, 28) & s: Exit Function
  93.         Else
  94.             s = Right(r & t, 28) & s: t = -1
  95.         End If
  96.     Next
  97.     s = (CDec(Left(a, n1 - i * 28 + 28)) + t) & s

  98.     For i = 1 To Len(s) - 1
  99.         If Mid(s, i, 1) > 0 Then Exit For
  100.     Next
  101.     LongMinus = Mid(s, i)
  102. End Function
  103. Function LargeMult$(ByVal a$, ByVal b&)  '计算任意多位数的a 乘以小数字b(<16位)
  104.     Dim i&, l&, m&, n&, s$, s0$, t$
  105.     l = 28 - Len("" & b)
  106.     s0 = String(28, "0")
  107.     n = Len(a): m = Int((n - 1) / l)
  108.     For i = 1 To m
  109.         t = Right(s0 & CDec(Mid(a, n - l * i + 1, l)) * b + Val(t), 28)
  110.         s = Right(t, l) & s
  111.         t = Left(t, 28 - l)
  112.     Next
  113.     LargeMult = (CDec(Left(a, n - l * m)) * b + Val(t)) & s
  114. End Function
  115. Function LongMult$(ByVal x$, ByVal y$) '长数位整数的相乘计算,返回长数位乘积
  116.     '在本附件中用作中间计算,以及可用于工作表自定义函数来验证平方计算结果
  117.     Dim i&, j&, l&, la&, lb&, n&, p&, s$
  118.    
  119.     If InStr(x, ".") Then p = Len(x) - InStr(x, "."): x = Replace(x, ".", "")
  120.     If InStr(y, ".") Then p = p + Len(y) - InStr(y, "."): y = Replace(y, ".", "")
  121.    
  122.     n = 12  'CDec +/-79,228,162,514,264,337,593,543,950,335
  123.    
  124.     la = (Len(x) - 1) \ n
  125.     ReDim a(la)
  126.     For i = 1 To la
  127.         a(i - 1) = CDec(Mid(x, Len(y) - n * i + 1, n))
  128.     Next
  129.     a(la) = CDec(Mid(x, 1, Len(x) - n * la))
  130.    
  131.     lb = (Len(y) - 1) \ n
  132.     ReDim b(lb)
  133.     For i = 1 To lb
  134.         b(i - 1) = CDec(Mid(y, Len(y) - n * i + 1, n))
  135.     Next
  136.     b(lb) = CDec(Mid(y, 1, Len(y) - n * lb))
  137.         
  138.     ReDim c(la + lb)
  139.     For i = 0 To la
  140.         For j = 0 To lb
  141.             c(la - i + lb - j) = c(la - i + lb - j) + a(i) * b(j)
  142.         Next
  143.     Next
  144.    
  145.     For i = la + lb To 1 Step -1
  146.         If Len(c(i)) > n Then
  147.             If i = 1 Then
  148.                 c(0) = c(0) + Left(c(i), Len(c(i)) - n)
  149.                 If Len(c(0)) > n Then c(0) = Left(c(0), Len(c(0)) - n) & Right(c(0), n)
  150.             Else
  151.                 c(i - 1) = Format(c(i - 1) + Left(c(i), Len(c(i)) - n), String(n, "0"))
  152.             End If
  153.             c(i) = Right(c(i), n)
  154.         ElseIf Len(c(i)) < n Then
  155.             c(i) = Format(c(i), String(n, "0"))
  156.         End If
  157.     Next
  158.    
  159.     s = Join(c, "")
  160.    
  161.     If p Then '有小数位时
  162.         If Len(s) > p Then '小数位在中间
  163.             s = Left(s, Len(s) - p) & "." & Right(s, p)
  164.         Else 'len(s)<p为首位0的含0纯小数
  165.             s = "0." & String(p - Len(s), "0") & s
  166.         End If
  167.         l = Len(s)
  168.         For i = 0 To p - 1
  169.             If Mid(s, l - i, 1) > 0 Then Exit For '检查多余的0
  170.         Next
  171.         If i = p Then s = Left(s, l - i - 1) Else s = Left(s, l - i)
  172.     End If
  173.    
  174.     LongMult = s
  175. End Function
复制代码

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 07:20 , Processed in 0.365658 second(s), 6 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表