ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 11534|回复: 22

[Excel 程序开发] [开_145-2]计算根号2,比精度比速度[已总结]

[复制链接]

TA的精华主题

TA的得分主题

发表于 2013-11-26 08:26 | 显示全部楼层 |阅读模式
本帖最后由 delete_007 于 2014-6-26 09:01 编辑

竞赛日期:2013-11-26至2013-12-20
题目内容:

根号 2 是个无理数,可以通过编程无限制的计算其小数点后面的数字。让我们来比一下谁能算得最精确,谁能算得最快 {:soso_e100:}

答题要求:

请按下述代码编写一个输出根号2的函数,返回数字文本:
  1. Public Function SQRT2(ByVal Length As Long, Optional ByRef dTime As Double) As String
  2.     Dim t#: t = Timer
  3.     On Error GoTo RTE
  4. ' ......
  5. END_FUNC:
  6.     t = Timer - t: dTime = t
  7.     Debug.Print "        ID: " & "<YOUR ID>"
  8.     Debug.Print " Time Used: " & Format(t, "0.00s")
  9.     Debug.Print "Calculated: " & Length & " digits of square root 2."
  10.     Exit Function
  11. RTE:
  12.     Err.Clear: On Error GoTo 0
  13.     dTime = -1
  14. End Function
复制代码
可自行添加所需要的任何其它过程或函数,但请设置为Private。如有外部变量也请设置为Private。方便汇总。

评分规则:

1、能够正确计算根号2(根号2的计算算法正确),不限长度,得 1 分
2、理论上能正确计算任意长度(Long型),不限时间,得 1 分
3、能在 4 秒内计算小数点后一万个准确数字的,得 1 分
4、评分人会根据代码,建议追加优秀代码分
执行速度以评分人的机器为准,下面的代码在我机器上约需 4 秒(可多次执行,取中间值):
  1. Sub TimeCompare_4Secs()
  2.     Dim i&, s$, t#
  3.     t = Timer
  4.     For i = 1 To 83500
  5.         s = s & Chr(Int(Rnd * 10 + 48))
  6.     Next
  7.     s = ""
  8.     Debug.Print Timer - t
  9. End Sub
复制代码
提示:

1、快速的根号 2 的计算方法
2、超大整数的四则运算的实现
3、用整数计算小数的办法

参考根号 2 小数点后100位:
1.41421356237309504880168872420969807856967187537694807317667973799073247846210703885038753432764157

是否参与评论:

可以参与

参考答案:

另加~




评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-6-12 12:37 | 显示全部楼层
抱歉拖了这么长时间,不过相信大家都知道结果了

测试结果如下:
  1. Testing length: 100
  2. ----------------------------
  3.         ID: Lee1892 - Origin Code
  4. Time Used: 0.0000s
  5. Calculated: 100 digits of square root 2.
  6. ----------------------------
  7.         ID: Lee1892 - Fast Code
  8. Time Used: 0.0000s
  9. Calculated: 100 digits of square root 2.
  10. ----------------------------
  11.         ID: 香川群子
  12. Time Used: 0.00s
  13. Calculated: 100 digits of square root 2.
  14. ----------------------------
  15.         ID: cleverzhzhf
  16. Time Used: 0.00s
  17. Calculated: 100 digits of square root 2.
  18. 楼03_cleverzhzhf is OUT for wrong digit too early.
  19. The wrong digit from number 2
  20. Right one is 1.41421356
  21. The answer is 10.0000000
  22. ----------------------------
  23.         ID: jsxjd
  24. Time Used: 0.00s
  25. Calculated: 100 digits of square root 2.
  26. ----------------------------
  27. ID: 苍海拾贝
  28. Time Used: 0.34s
  29. Calculated: 100 digits of square root 2.
  30. ----------------------------
  31.         ID: doryan
  32. Time Used: 0.00s
  33. Calculated: 100 digits of square root 2.
  34. 楼07_doryan is OUT for wrong digit too early.
  35. The wrong digit from number 2
  36. Right one is 1.41421356
  37. The answer is 10.
  38. ============================
  39. Testing length: 300
  40. ----------------------------
  41.         ID: Lee1892 - Origin Code
  42. Time Used: 0.0156s
  43. Calculated: 300 digits of square root 2.
  44. ----------------------------
  45.         ID: Lee1892 - Fast Code
  46. Time Used: 0.0000s
  47. Calculated: 300 digits of square root 2.
  48. ----------------------------
  49.         ID: 香川群子
  50. Time Used: 0.03s
  51. Calculated: 300 digits of square root 2.
  52. ----------------------------
  53. 楼03_cleverzhzhf is already OUT.
  54. ----------------------------
  55.         ID: jsxjd
  56. Time Used: 0.00s
  57. Calculated: 300 digits of square root 2.
  58. ----------------------------
  59. ID: 苍海拾贝
  60. Time Used: 7.72s
  61. Calculated: 300 digits of square root 2.
  62. 楼06_苍海拾贝 is OUT for overtime using.
  63. ----------------------------
  64. 楼07_doryan is already OUT.
  65. ============================
  66. Testing length: 1000
  67. ----------------------------
  68.         ID: Lee1892 - Origin Code
  69. Time Used: 0.0156s
  70. Calculated: 1000 digits of square root 2.
  71. ----------------------------
  72.         ID: Lee1892 - Fast Code
  73. Time Used: 0.0156s
  74. Calculated: 1000 digits of square root 2.
  75. ----------------------------
  76.         ID: 香川群子
  77. Time Used: 0.48s
  78. Calculated: 1000 digits of square root 2.
  79. ----------------------------
  80. 楼03_cleverzhzhf is already OUT.
  81. ----------------------------
  82.         ID: jsxjd
  83. Time Used: 0.02s
  84. Calculated: 1000 digits of square root 2.
  85. ----------------------------
  86. 楼06_苍海拾贝 is already OUT.
  87. ----------------------------
  88. 楼07_doryan is already OUT.
  89. ============================
  90. Testing length: 3000
  91. ----------------------------
  92.         ID: Lee1892 - Origin Code
  93. Time Used: 0.2031s
  94. Calculated: 3000 digits of square root 2.
  95. ----------------------------
  96.         ID: Lee1892 - Fast Code
  97. Time Used: 0.0469s
  98. Calculated: 3000 digits of square root 2.
  99. ----------------------------
  100.         ID: 香川群子
  101. Time Used: 9.05s
  102. Calculated: 3000 digits of square root 2.
  103. 楼02_香川群子 is OUT for overtime using.
  104. 楼02_香川群子 is OUT for wrong digit too early.
  105. The wrong digit from number 2708
  106. Right one is 9314549999
  107. The answer is 9314559999
  108. ----------------------------
  109. 楼03_cleverzhzhf is already OUT.
  110. ----------------------------
  111.         ID: jsxjd
  112. Time Used: 0.05s
  113. Calculated: 3000 digits of square root 2.
  114. ----------------------------
  115. 楼06_苍海拾贝 is already OUT.
  116. ----------------------------
  117. 楼07_doryan is already OUT.
  118. ============================
  119. Testing length: 5000
  120. ----------------------------
  121.         ID: Lee1892 - Origin Code
  122. Time Used: 0.5469s
  123. Calculated: 5000 digits of square root 2.
  124. ----------------------------
  125.         ID: Lee1892 - Fast Code
  126. Time Used: 0.1406s
  127. Calculated: 5000 digits of square root 2.
  128. ----------------------------
  129. 楼02_香川群子 is already OUT.
  130. ----------------------------
  131. 楼03_cleverzhzhf is already OUT.
  132. ----------------------------
  133.         ID: jsxjd
  134. Time Used: 0.13s
  135. Calculated: 5000 digits of square root 2.
  136. ----------------------------
  137. 楼06_苍海拾贝 is already OUT.
  138. ----------------------------
  139. 楼07_doryan is already OUT.
  140. ============================
  141. Testing length: 10000
  142. ----------------------------
  143.         ID: Lee1892 - Origin Code
  144. Time Used: 2.2031s
  145. Calculated: 10000 digits of square root 2.
  146. ----------------------------
  147.         ID: Lee1892 - Fast Code
  148. Time Used: 0.5313s
  149. Calculated: 10000 digits of square root 2.
  150. ----------------------------
  151. 楼02_香川群子 is already OUT.
  152. ----------------------------
  153. 楼03_cleverzhzhf is already OUT.
  154. ----------------------------
  155.         ID: jsxjd
  156. Time Used: 0.47s
  157. Calculated: 10000 digits of square root 2.
  158. ----------------------------
  159. 楼06_苍海拾贝 is already OUT.
  160. ----------------------------
  161. 楼07_doryan is already OUT.
  162. ============================
复制代码
ID 正确计算 计算任意长度 4秒计算万位 优秀代码 奖励合计
香川群子 2 技术分
cleverzhzhf 参与比赛财富奖励
jsxjd 4 技术分
苍海拾贝 2 技术分
doryan 参与比赛财富奖励

香川的代码在2708位会出现错误,不知是何原因

Square root 2.zip

59.41 KB, 下载次数: 52

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-11-26 17:07 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 香川群子 于 2013-12-10 09:24 编辑

图片为2450位的答案参考:


…………
我觉得找到好的正确的算法是主要的关键。写代码倒是其次。呵呵。

2开方_kagawa.rar (19.63 KB, 下载次数: 34)

一直没空……终于有空写了个简单的代码,先看结果是否正确,速度还来不及优化。

主代码倒是比较简单:

    a$ = Left(2 ^ 0.5, 16)
    N_2a$ = Left("0" & 1 / a, 17)
    a_2$ = Left("0" & a / 2, 17)
    '三个计算参数的初始化

    Do Until Len(a) > Length
        a$ = PM_2(a, N_2a, a_2)
        N_2a$ = DV_2a(a, N_2a)
        a_2$ = DV_2(a, a_2)
    Loop '循环计算直至达到长度要求
    SQRT2 = Left(a, Length) '输出结果


结果不理想。
第一、速度慢,第二、计算到2708位时有错误了。



补充内容 (2013-12-10 20:09):
代码错误用检查乘积的方法解决了……现在的问题是速度太慢了。
SQRT2.jpg

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-11-29 17:29 | 显示全部楼层
本帖最后由 cleverzhzhf 于 2013-12-2 12:44 编辑

超大整数的,暂时还实现不了,先弄一个,可以计算任意Long数字的,精度以Double为准:
  1. Function SqrTwo(ByVal Length As Long) As String
  2.     Dim t#: t = Timer
  3.     Dim iCmp As Double, iLen As Integer
  4.     Dim strLength As String, strOri As String
  5.     iLen = Len(CStr(Length))
  6.     If iLen Mod 2 = 1 Then  '判定数字长度是奇数还是偶数,对奇数位数字,前面加0,补成偶数位
  7.         strLength = 0 & Length
  8.     Else
  9.         strLength = Length
  10.     End If
  11.     iLen = Len(strLength)
  12.     iDotPosi = iLen / 2 '计算以整数计算,最终确定字符串插入小数点的位置
  13.     strOri = Left(strLength, 2)
  14.     iOri = CInt(strOri)
  15.     For i = 0 To 9  '先得到第一位数的结果
  16.         If i ^ 2 > iOri Then Exit For
  17.     Next
  18.     iCmp = iOri - (i - 1) ^ 2
  19. '    iCmp = Val(iCmp & "00")
  20.     strResult = (i - 1)
  21.     On Error GoTo Result    '当超过Double的限制时跳出循环
  22.     Do
  23.         m = m + 1
  24.         If m * 2 < iLen Then    '根据计算理论(10a+b)^2=(10a)^2+b*(20a+b)
  25.             iCmp = iCmp * 100 + Mid(strLength, m * 2 + 1, 2)    '如果计算数字,还有数,则向后取两位
  26.         Else
  27.             iCmp = iCmp * 100   '如果计算数字已经没数,补两个0在最后,继续计算
  28.         End If
  29.         For j = 0 To 9
  30.             If (CDbl(strResult) * 20 + j) * j > iCmp Then Exit For
  31.         Next
  32.         iCmp = (iCmp - (CDbl(strResult) * 20 + j - 1) * (j - 1))    '下一个将要做减法的数字:=上一次遗留数-b*(20*已得结果+b)
  33.          strResult = strResult & j - 1
  34.     Loop Until Len(strResult) > 10000
  35. Result:
  36.     SqrTwo = Application.Replace(strResult, iDotPosi + 1, 0, ".")
  37.     Debug.Print "        ID: " & "cleverzhzhf"
  38.     Debug.Print " Time Used: " & Format(Timer - t, "0.00s")
  39.     Debug.Print "Calculated: " & Length & " digits of square root 2."
  40. End Function
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-12-2 00:08 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2013-12-7 22:01 | 显示全部楼层
本帖最后由 jsxjd 于 2013-12-9 21:18 编辑

根据楼主的100位示例代码,返回的位数是包括“1.”在内的“总位数”
10000 位本机执行0.34秒,最后100位为:
4644372856895928683197779778693464159846974513391774153790487788083002205833504674655532302858732583
20000 位本机执行1.34秒,最后100位为:
2299688266236189437975463431486940473705466022052365853522433491893414953731854617756390850630149805
  1. Public Function SQRT2(ByVal Length As Long, Optional ByRef dTime As Double) As String
  2.     Dim t#: t = Timer
  3.     On Error GoTo RTE
  4. ' ......
  5.     Dim tempNominator&, Nominator&, Denominator&
  6.     Dim SqrtLen&, i&, kk&, Product&, Carry&
  7.     Dim NoneZero&, newNoneZero&, rank&, C0&, C1&
  8.     Dim Root&(30000), Rst&(1, 30000) '可适当修改
  9.     If Length < 1 Then Exit Function
  10.     SqrtLen = (Length + 120) \ 4
  11.    
  12.     Const FirstDigit& = 10
  13.     Root(FirstDigit) = 1: Rst(0, FirstDigit) = 1: NoneZero = FirstDigit
  14.     tempNominator = -3: rank = 1
  15.     For kk = 1 To SqrtLen
  16.         tempNominator = tempNominator + 2
  17.         Nominator = Abs(tempNominator)
  18.         
  19.         Product = 0
  20.         For i = SqrtLen To NoneZero - FirstDigit Step -1  ' *(2kk-3)
  21.             Product = Root(i) * Nominator + (Product \ 10000)
  22.             Root(i) = Product Mod 10000
  23.         Next
  24.         
  25.         Product = 0
  26.         Denominator = tempNominator + 3
  27.         For i = NoneZero - FirstDigit To SqrtLen  ' / 2kk
  28.             Product = 10000 * (Product Mod Denominator) + Root(i)
  29.             Root(i) = Product \ Denominator
  30.         Next
  31.    
  32.         Product = 0
  33.         For i = NoneZero - FirstDigit To SqrtLen  ' *65918161
  34.             Product = 10000 * (Product Mod 8119) + Root(i)
  35.             Root(i) = Product \ 8119
  36.         Next
  37.         
  38.         Product = 0: rank = 1 - rank
  39.         For i = NoneZero - FirstDigit To SqrtLen  ' *65918161
  40.             Product = 10000 * (Product Mod 8119) + Root(i)
  41.             Root(i) = Product \ 8119
  42.             Rst(rank, i) = Rst(rank, i) + Root(i)
  43.         Next
  44.         
  45.         newNoneZero = SqrtLen + 1
  46.         For i = NoneZero To SqrtLen
  47.             If Root(i) > 0 Then
  48.                 newNoneZero = i
  49.                 Exit For
  50.             End If
  51.         Next
  52.         If newNoneZero > SqrtLen Then Exit For
  53.         NoneZero = newNoneZero
  54.     Next
  55.     For i = SqrtLen To 0 Step -1
  56.         C0 = (C0 \ 10000) + Rst(0, i)
  57.         Rst(0, i) = C0 Mod 10000
  58.         C1 = (C1 \ 10000) + Rst(1, i)
  59.         Rst(1, i) = C1 Mod 10000
  60.     Next
  61.     '''''''''''''''''''''''''''''''''
  62.     C0 = 0: Carry = 0
  63.     For i = SqrtLen To 0 Step -1
  64.         C0 = Int(C0 / 10000) + Rst(0, i) - Rst(1, i)
  65.         Product = 8119 * ((1000000 + C0) Mod 10000) + Carry
  66.         Root(i) = Product Mod 10000
  67.         Carry = Product \ 10000
  68.     Next
  69.    
  70.     Carry = 0
  71.     For i = 0 To SqrtLen
  72.         Product = 10000 * Carry + Root(i)
  73.         Root(i) = Product \ 5741
  74.         Carry = Product Mod 5741
  75.     Next
  76.    
  77.     SQRT2 = Root(FirstDigit) & "."
  78.     For i = FirstDigit + 1 To SqrtLen
  79.         SQRT2 = SQRT2 & Format(Root(i), "0000")
  80.     Next
  81.     SQRT2 = Left(SQRT2, Length)
  82. ' ......
  83. END_FUNC:
  84.     t = Timer - t: dTime = t
  85.     Debug.Print "        ID: " & "<jsxjd>"
  86.     Debug.Print " Time Used: " & Format(t, "0.00s")
  87.     Debug.Print "Calculated: " & Length & " digits of square root 2."
  88.     Exit Function
  89. RTE:
  90.     Err.Clear: On Error GoTo 0
  91.     dTime = -1
  92. End Function
复制代码
另外,楼主给的4秒代码耗时不太稳定,请帮忙测试一下以便改进。

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-12-9 22:03 | 显示全部楼层
  1. '大数加法
  2. Private Sub BigintAdd(ByVal n As Integer, ByRef a() As Long, ByRef b() As Long, ByRef c() As Long, Optional ca As Integer = 1, Optional cb As Integer = 1)
  3.     Dim i As Integer
  4.     For i = 0 To n - 1
  5.         c(i) = ca * a(i) + cb * b(i)
  6.     Next
  7.     Progress n, c
  8. End Sub
  9. '大数除法
  10. Private Sub BigintDiv(ByVal n As Integer, ByRef a() As Long, ByVal dv As Integer)
  11.     Dim i, k As Integer
  12.     For i = 0 To n - 2
  13.         k = a(i)
  14.         a(i) = Int(a(i) / dv)
  15.         a(i + 1) = a(i + 1) + 10 * (k Mod dv)
  16.     Next
  17.     a(n - 1) = Int(a(n - 1) / dv)
  18. End Sub
  19. '大数乘法
  20. Private Sub BigintMul(ByVal n As Integer, ByRef a() As Long, ByRef b() As Long, ByRef c() As Long)
  21.     Dim i, j As Integer
  22.     For i = 0 To n - 1
  23.         c(i) = 0
  24.     Next
  25.     For i = 0 To n - 1
  26.         For j = 0 To n - i - 1
  27.             c(i + j) = c(i + j) + a(i) * b(j)
  28.         Next
  29.     Next
  30.     Progress n, c
  31. End Sub
  32. '大数进位
  33. Private Sub Progress(ByVal n As Integer, ByRef a() As Long)
  34.     Dim i, na As Integer
  35.     na = 0
  36.     For i = 0 To n - 1
  37.         If a(i) > 0 Then
  38.             na = i
  39.             Exit For
  40.         End If
  41.     Next
  42.     For i = n - 1 To na + 1 Step -1
  43.         a(i - 1) = a(i - 1) + Int(a(i) / 10)
  44.         a(i) = a(i) Mod 10
  45.     Next
  46.   End Sub
  47. Public Function SQRT2(ByVal Length As Long, Optional ByRef dTime As Double) As String
  48.     Dim t#: t = Timer
  49.     On Error GoTo RTE
  50. ' .....................................................................................

  51.     Dim a(0 To 10000) As Long
  52.     Dim b(0 To 10000) As Long
  53.     Dim c(0 To 10000) As Long
  54.     Dim d(0 To 10000) As Long
  55.     Dim result As String
  56.     Dim n, eps, i, ic As Integer
  57.     Dim l1 As Long
  58.    
  59.     l1 = 2   '需要开方数据
  60.     eps = Length - 1 '精度,计算出的数字个数
  61.     n = Length + 5 '数组大小
  62.    
  63.     a(0) = 0
  64.     b(0) = Int(Sqr(l1)) * 2
  65.     c(0) = Int(Sqr(l1))
  66.     Do While b(0) * b(0) / 4 <> l1
  67.         ic = 0
  68.         For i = 0 To eps - 1
  69.             ic = ic + Abs(b(i) - a(i))
  70.         Next
  71.         If ic = 0 Then Exit Do
  72.         
  73.         BigintAdd n, a, b, c
  74.         BigintDiv n, c, 2
  75.         BigintMul n, c, c, d
  76.         
  77.         If d(0) >= l1 Then
  78.             For i = 0 To n - 1
  79.                 b(i) = c(i)
  80.             Next
  81.         Else
  82.             For i = 0 To n - 1
  83.                 a(i) = c(i)
  84.             Next
  85.         End If
  86.     Loop

  87.     For i = 0 To eps - 1
  88.         result = result & c(i)
  89.     Next
  90.     SQRT2 = Left(result, Len(Trim(Int(Sqr(l1))))) & "." & Right(result, Len(result) - Len(Trim(Int(Sqr(l1)))))

  91. END_FUNC:
  92.     t = Timer - t: dTime = t
  93.     Debug.Print "ID: " & "苍海拾贝"
  94.     Debug.Print "Time Used: " & Format(t, "0.00s")
  95.     Debug.Print "Calculated: " & Length & " digits of square root 2."
  96.     Exit Function
  97. RTE:
  98.     err.Clear: On Error GoTo 0
  99.     dTime = -1
  100. End Function
复制代码
位数越大,速度越慢,能力有限,继续学习

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-12-11 16:32 | 显示全部楼层
本帖最后由 doryan 于 2013-12-12 15:39 编辑

先发一份满足条件1和条件2的
手工开方的代码表现  LONG支持  double不支持
如楼主提示一般 自己重写了字符串形式的四则运算 来解决溢出问题
但由于算法优化不太懂 太多的数组和字符串操作 速度较慢 1000位都需要8秒 建议只测试到100位

另外指出楼主给出的参考是小数点后98位 100位应该是
1.4142135623730950488016887242096980785696718753769480731766797379907324784621070388503875343276415727
  1. Public Function SQRT2(ByVal Length As Long, Optional ByRef dTime As Double) As String
  2.     Dim t#: t = Timer
  3.     On Error GoTo RTE
  4.     SQRT2 = ss(Length, dTime)
  5. END_FUNC:
  6.     t = Timer - t: dTime = t
  7.     Debug.Print "        ID: " & "<doryan>"
  8.     Debug.Print " Time Used: " & Format(t, "0.00s")
  9.     Debug.Print "Calculated: " & Length & " digits of square root 2."
  10.     Exit Function
  11. RTE:
  12.     Err.Clear: On Error GoTo 0
  13.     dTime = -1
  14. End Function
  15. Private Function ss(num, n) As String
  16.     Dim numstr As String
  17.     Dim yushu As String
  18.     Dim zhengshu As String, zsLen As Integer
  19.     Dim gen As Long
  20.     Dim kaifang As Long
  21.     kaifang = Application.WorksheetFunction.RoundDown((VBA.Sqr(num)), 0)
  22.     zhengshu = CStr(kaifang)
  23.     zsLen = Len(zhengshu)
  24.     gen = kaifang ^ 2
  25.     yushu = (num - gen)
  26. '    If Len(num) Mod 2 <> 0 Then
  27. '        numstr = "0" & num & Application.WorksheetFunction.Rept("0", n * 2)
  28. '    Else
  29. '        numstr = "" & num & Application.WorksheetFunction.Rept("0", n * 2)
  30. '    End If
  31.     Dim shishang As String
  32.     Dim bigger As Integer
  33.     Dim shiji As String
  34.     For i = 1 To n
  35.         yushu = yushu & "00"
  36.         shishang = ChengFa(zhengshu & "", "", True)
  37.         For j = CInt(chufa(yushu, shishang)) To 0 Step -1
  38.             shiji = ChengFa(JiaFa(shishang, j & ""), j & "")
  39.             bigger = CompareVal(yushu, shiji)
  40.             If bigger = 1 Then
  41.                 zhengshu = zhengshu & j
  42.                 yushu = JianFa(yushu, shiji)
  43.                 Exit For
  44.             ElseIf bigger = -1 Then
  45.                
  46.             Else
  47.                 zhengshu = zhengshu & j
  48.                 Exit For
  49.             End If
  50.         Next
  51.     Next
  52.     If n > 0 Then
  53.     ss = Left(zhengshu, Len(CStr(kaifang))) & "." & Mid(zhengshu, Len(CStr(kaifang)) + 1)
  54.     Else
  55.     ss = CStr(kaifang)
  56.     End If
  57. End Function
  58. Private Function chufa(a1 As String, a2 As String)
  59.     Dim l1 As Long, l2 As Long
  60.     Dim T1 As String, T2 As String
  61.     l1 = Len(a1)
  62.     l2 = Len(a2)
  63.     If CompareVal(a1, a2) = -1 Then
  64.         chufa = "0"
  65.     Else
  66.         T1 = Left(a1, l1 - (l2 - 1))
  67.         T2 = Left(a2, 1)
  68.         chufa = CInt(T1) / CInt(T2) + 1
  69.         If chufa > 9 Then chufa = 9
  70.     End If
  71. End Function
  72. Private Function ChengFa(a1 As String, a2 As String, Optional Twenty = False)
  73.     If Twenty Then
  74.         ChengFa = subChengFa(a1, 2) & "0"
  75.     Else
  76.         ChengFa = subChengFa(a1, a2)
  77.     End If
  78. End Function

  79. Private Function subChengFa(a1 As String, a2 As String)
  80.     Dim l1 As Long, l2 As Long, l3 As Long
  81.     l1 = Len(a1) + 1
  82.     l2 = Len(a2)
  83.     Dim arr()
  84.     ReDim arr(1 To l1)
  85.     arr(1) = "0"
  86.     For i = l1 To 2 Step -1
  87.         arr(i) = Mid(a1, i - 1, 1) * CInt(a2)
  88.     Next
  89.     For i = l1 To 2 Step -1
  90.         If Len(arr(i)) > 1 Then
  91.            arr(i - 1) = CInt(arr(i - 1)) + CInt(Left(arr(i), 1))
  92.            arr(i) = Right(arr(i), 1)
  93.         End If
  94.     Next
  95.     Dim pos As Integer
  96.     For i = 1 To l1
  97.         If arr(i) = 0 Then
  98.         pos = i
  99.         Else
  100.         Exit For
  101.         End If
  102.     Next
  103.     If pos = l1 Then
  104.     subChengFa = "0"
  105.     Else
  106.     subChengFa = Mid(Join(arr, ""), pos + 1)
  107.     End If
  108. End Function

  109. Private Function JianFa(a1 As String, a2 As String)
  110.     Dim l1 As Long, l2 As Long
  111.     l1 = Len(a1)
  112.     l2 = Len(a2)
  113.     a2 = Application.WorksheetFunction.Rept("0", l1 - l2) & a2
  114.     Dim arr()
  115.     ReDim arr(1 To l1)
  116.     For i = l1 To 1 Step -1
  117.         arr(i) = Mid(a1, i, 1) - Mid(a2, i, 1)
  118.     Next
  119.     For i = l1 To 1 Step -1
  120.         If arr(i) < 0 Then
  121.             arr(i - 1) = arr(i - 1) - 1
  122.             arr(i) = 10 + arr(i)
  123.         End If
  124.     Next
  125.     Dim pos As Integer
  126.     For i = 1 To l1
  127.         If arr(i) = 0 Then
  128.         pos = i
  129.         Else
  130.         Exit For
  131.         End If
  132.     Next
  133.     If pos = l1 Then
  134.     JianFa = "0"
  135.     Else
  136.     JianFa = Mid(Join(arr, ""), pos + 1)
  137.     End If
  138. End Function

  139. Private Function JiaFa(a1 As String, a2 As String)
  140.     Dim l1 As Long, l2 As Long
  141.     l1 = Len(a1) + 1
  142.     l2 = Len(a2)
  143.     a2 = Application.WorksheetFunction.Rept("0", l1 - l2 - 1) & a2
  144.     Dim arr()
  145.     ReDim arr(1 To l1)
  146.     arr(1) = "0"
  147.     For i = l1 To 2 Step -1
  148.         arr(i) = CInt(Mid(a1, i - 1, 1)) + CInt(Mid(a2, i - 1, 1))
  149.     Next
  150.     For i = l1 To 1 Step -1
  151.         If Len(arr(i)) > 1 Then
  152.             arr(i - 1) = arr(i - 1) + 1
  153.             arr(i) = arr(i) - 10
  154.         End If
  155.     Next
  156.     Dim pos As Integer
  157.     For i = 1 To l1
  158.         If arr(i) = 0 Then
  159.         pos = i
  160.         Else
  161.         Exit For
  162.         End If
  163.     Next
  164.     If pos = l1 Then
  165.     JiaFa = "0"
  166.     Else
  167.     JiaFa = Mid(Join(arr, ""), pos + 1)
  168.     End If
  169. End Function

  170. Private Function CompareVal(a1 As String, a2 As String)
  171.     Dim l1 As Long, l2 As Long
  172.     l1 = Len(a1)
  173.     l2 = Len(a2)
  174.     If l1 > l2 Then
  175.         CompareVal = 1
  176.     ElseIf l1 = l2 Then
  177.         Dim m1 As Integer, m2 As Integer
  178.         For i = 1 To l1
  179.             m1 = CInt(Mid(a1, i, 1))
  180.             m2 = CInt(Mid(a2, i, 1))
  181.             If m1 > m2 Then
  182.                CompareVal = 1
  183.                Exit Function
  184.             ElseIf m1 = m2 Then
  185.                GoTo NEXTLOOP
  186.             Else
  187.                CompareVal = -1
  188.                Exit Function
  189.             End If
  190. NEXTLOOP:
  191.         Next
  192.         CompareVal = 1
  193.     Else
  194.         CompareVal = -1
  195.     End If
  196. End Function
  197. Private Sub TimeCompare_4Secs()
  198.     Dim i&, s$, t#
  199.     t = Timer
  200.     For i = 1 To 83500
  201.         s = s & Chr(Int(Rnd * 10 + 48))
  202.     Next
  203.     s = ""
  204.     Debug.Print Timer - t
  205. End Sub
复制代码

点评

这么长的代码!佩服。  发表于 2014-1-2 14:51

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-12-23 16:05 | 显示全部楼层
答题截止日期已至,先开帖。
请楼主给出评分建议及总结。

TA的精华主题

TA的得分主题

 楼主| 发表于 2013-12-23 20:59 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2013-12-23 21:38 | 显示全部楼层
好的,月底写总结没问题。
相信延迟几天大家也是可以谅解的。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-4-28 16:44 , Processed in 0.061662 second(s), 22 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

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