ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[Excel 程序开发] [第96期]换硬币[已总结]

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2013-8-10 19:37 | 显示全部楼层
本帖最后由 yuanhongly 于 2013-8-10 20:07 编辑

贴上来的代码乱码了    删了楼下贴过。{:soso_e106:}

TA的精华主题

TA的得分主题

发表于 2013-8-10 20:01 | 显示全部楼层
本帖最后由 yuanhongly 于 2013-8-12 13:41 编辑

上面批注乱码了{:soso_e121:}测试了一长串9的天文数字 也只要零点几秒 应该算OK吧
用数组和字典记录换过的金额都可以,但测试数组比字典慢一点点,而且换的金额大到一定数量后可能导致溢出,所以就用字典了。
[code=vb]Dim d As Object
Function HQ(i)
    If d.Exists(i) Then'已兑换过的金额(兑换记录)
        HQ = d(i)
        Exit Function
    End If
    If i < 12 Then '2\3\4最小公倍数
        HQ = i
    Else
        HQ = HQ(Int(i / 2)) + HQ(Int(i / 3)) + HQ(Int(i / 4))
        d(i) = HQ'字典收录此次兑换结果
    End If
End Function

Sub ChangeCoin()
    Dim aCoins(), aRes(), nCoin, t#
    ' 可更改段
    ' 只能是Dim
    Dim i%
    ' 可更改结束
    aCoins = Array(12, 123, 1000, 50000, 600000, 30000000)
    ReDim aRes(UBound(aCoins))
    t = Timer
    ' 可更改段
    Set d = CreateObject("Scripting.Dictionary")
    For Each nCoin In aCoins
        aRes(i) = HQ(nCoin)
        i = i + 1
    Next
     d.RemoveAll: Set d = Nothing
    ' 可更改结束
    Debug.Print "ID: " & "<yuanhongly>"
    Debug.Print "Result: " & Join(aRes, ", ")
    Debug.Print "Time: " & Format(Timer - t, "0.000s")
End Sub

Sub test()
    t = Timer
    Set d = CreateObject("Scripting.Dictionary")
    Debug.Print "Result: " & HQ(1E+23)  '兑换数值为99999999999999999999999 超级富豪兑换测试
    d.RemoveAll: Set d = Nothing
    Debug.Print "Time: " & Format(Timer - t, "0.000s")
End Sub[/code]



评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-8-18 18:00 | 显示全部楼层
本帖最后由 xzk235 于 2013-8-18 18:14 编辑

第一次发VB格式代码,第一次感觉没对,重编辑就搞成两份去了。全删了重来一次试试。
[code=vb]Public d
Sub ChangeCoin()
    Dim aCoins(), aRes(), nCoin, t#
    ' 可更改段
    ' 只能是Dim
    ' 可更改结束
    aCoins = Array(12, 123, 1000, 50000, 600000, 30000000)
    ReDim aRes(UBound(aCoins))
    t = Timer
    ' 可更改段
    Set d = CreateObject("scripting.dictionary")
    i = 0
    For Each nCoin In aCoins
        aRes(i) = ff(nCoin)
        i = i + 1
    Next
    ' 可更改结束
    Debug.Print "ID: " & "xzk235"
    Debug.Print "Result: " & Join(aRes, ", ")
    Debug.Print "Time: " & Format(Timer - t, "0.000s")
End Sub
Function ff(n)
    If d.exists(n) Then
        ff = d(n)
    Else
        su = 0
        For i = 2 To 4
            temp = Int(n / i)
            If temp > 4 Then
            su = su + Application.Max(temp, ff(temp))
            Else
            su = su + temp
            End If
        Next
        d(n) = su
        ff = su
    End If
End Function
[/code]

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-8-19 13:28 | 显示全部楼层
Sub ChangeCoin()
    Dim aCoins(), aRes(), nCoin, t#
    ' 可更改段
    ' 只能是Dim
    ' 可更改结束
    aCoins = Array(12, 123, 1000, 50000, 600000, 30000000)
    ReDim aRes(UBound(aCoins))
    t = Timer
    ' 可更改段
    k = 0
    For Each nCoin In aCoins
        '....
        aRes(k) = y(nCoin)
    k = k + 1
    Next
    ' 可更改结束
    Debug.Print "ID: " & "hellohaha"
    Debug.Print "Result: " & Join(aRes, ", ")
    Debug.Print "Time: " & Format(Timer - t, "0.000s")
End Sub

Function y(x)
If x < 12 Then
y = x
Else
y = y(Int(x / 2)) + y(Int(x / 3)) + y(Int(x / 4))
End If
End Function

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-8-20 10:56 | 显示全部楼层
本帖最后由 huahua2005 于 2013-8-20 20:53 编辑

花了一天看了GGSMART老师的vba入门帖,来做这个题,是因为对竞赛感兴趣,新手的程序语句效率不高,请楼主见谅~
我的机器时间:0.480s(6个结果0.5秒钟以内,单个结果0.08秒左右),先发上来,有时间再继续优化~
ID: <huahua2005>
Result: 13, 144, 1370, 96394, 1427537, 98274986
Time: 0.480s


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-8-25 20:27 | 显示全部楼层
本帖最后由 xiaofx11 于 2013-8-25 20:31 编辑

五楼是我,没法编辑原贴,新补充一个字典的函数,原题不变
前期引用Microsoft Scripting Runtime
声名公有变量
Dim dic As New Dictionary


  1. Dim dic As New Dictionary
  2. Sub ChangeCoin()
  3.     Dim aCoins(), aRes(), nCoin, t#, i As Long
  4.     aCoins = Array(12, 123, 1000, 50000, 600000, 30000000)
  5.     ReDim aRes(UBound(aCoins))
  6.     t = Timer
  7.     i = 0
  8.     For Each nCoin In aCoins
  9.         aRes(i) = xiaofx11(nCoin)
  10.         i = i + 1
  11.         dic.RemoveAll
  12.     Next
  13.     ' 可更改结束
  14.     Debug.Print "ID: " & "xiaofx11"
  15.     Debug.Print "Result: " & Join(aRes, ", ")
  16.     Debug.Print "Time: " & Format(Timer - t, "0.000s")
  17. End Sub
  18. Public Function xiaofx11(ByVal x As Long) As Long
  19. Dim temp2, temp3, temp4
  20.     If x \ 2 + x \ 3 + x \ 4 > x Then
  21.         '----------
  22.         If dic.Exists(x \ 2) Then
  23.             temp2 = dic(x \ 2)
  24.         Else
  25.             temp2 = xiaofx11(x \ 2)
  26.         End If
  27.         '----------
  28.         If dic.Exists(x \ 3) Then
  29.             temp3 = dic(x \ 3)
  30.         Else
  31.             temp3 = xiaofx11(x \ 3)
  32.         End If
  33.         '----------
  34.         If dic.Exists(x \ 4) Then
  35.             temp4 = dic(x \ 4)
  36.         Else
  37.             temp4 = xiaofx11(x \ 4)
  38.         End If
  39.         xiaofx11 = temp2 + temp3 + temp4
  40.     Else
  41.         xiaofx11 = x
  42.     End If
  43.     dic(x) = xiaofx11
  44. End Function
复制代码

TA的精华主题

TA的得分主题

发表于 2013-8-26 12:18 | 显示全部楼层
本帖最后由 Bodhidharma 于 2013-8-26 12:30 编辑

第一次寫VBA程式,不知如何在Sub中再另外新增函數
故使用STACK實現RECURSION
不知道格式是否符合要求

  1. Sub ChangeCoin()
  2. Dim aCoins(), aRes(), nCoin, t#
  3. ' 可更改段
  4. Dim ansArray(0 To 10000), i, j, top, n(1 To 10000), stage(1 To 10000), ans
  5. ' 只能是Dim
  6. ' 可更改結束
  7. aCoins = Array(12, 123, 1000, 50000, 600000, 30000000)
  8. ReDim aRes(UBound(aCoins))
  9. t = Timer
  10. ' 可更改段

  11. For i = 0 To 10000
  12.     If i >= -Fix(-i / 2) - Fix(-i / 3) - Fix(-i / 4) Then
  13.     ansArray(i) = i
  14.     Else
  15.     ansArray(i) = ansArray(-Fix(-i / 2)) + ansArray(-Fix(-i / 3)) + ansArray(-Fix(-i / 4))
  16.     End If
  17. Next
  18.    
  19. j = 0
  20. For Each nCoin In aCoins
  21.     ans = 0
  22.     top = 1
  23.     n(top) = nCoin
  24.     stage(top) = 1
  25.     Do While top > 0
  26.         If stage(top) = 1 Then
  27.             stage(top) = 0
  28.             If n(top) >= 10000 Then
  29.                 top = top + 1
  30.                 stage(top) = 1
  31.                 n(top) = -Fix(-n(top - 1) / 2)
  32.                 top = top + 1
  33.                 stage(top) = 1
  34.                 n(top) = -Fix(-n(top - 2) / 3)
  35.                 top = top + 1
  36.                 stage(top) = 1
  37.                 n(top) = -Fix(-n(top - 3) / 4)
  38.             End If
  39.         Else
  40.             If n(top) < 10000 Then
  41.             ans = ans + ansArray(n(top))
  42.             End If
  43.             top = top - 1
  44.         End If
  45.     Loop
  46. aRes(j) = ans
  47. j = j + 1
  48. Next

  49. ' 可更改結束

  50. Debug.Print "ID: " & "Bodhidharma"
  51. Debug.Print "Result: " & Join(aRes, ", ")
  52. Debug.Print "Time: " & Format(Timer - t, "0.000s")
  53. End Sub
复制代码





本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-8-26 21:11 | 显示全部楼层
' 2.66 GHz 2GM
' 对面值 <40 进行单独处理,速度略有提高,当然也可设置常量数组
' 在原数组的基础上添加 10 ^ 9 和 30000,循环 100 次稳定在 0.43 秒,平均 0.0043秒
' 10^9:平均 0.0022 秒
  1. Sub ChangeCoin_JsXjd()
  2.     Dim aCoins(), aRes(), nCoin, t#
  3.     ' 可更改段
  4.     ' 只能是Dim
  5.     Dim sourceDict, faceValue
  6.     Dim coinIndex&, NofFaceValue&, divsor&, changedCoin&, matchCoin&
  7.     ' 可更改结束
  8.     aCoins = Array(12, 123, 1000, 50000, 600000, 30000000, 10 ^ 9, 30000)
  9.     '                                                      =============
  10.     ReDim aRes(UBound(aCoins))
  11.     t = Timer
  12.     ' 可更改段
  13.     coinIndex = 0
  14.     Set sourceDict = CreateObject("Scripting.Dictionary")
  15.     ' 可更改段
  16.     For Each nCoin In aCoins
  17.         '....
  18.         sourceDict(nCoin) = 1
  19.         While sourceDict.Count > 0
  20.             For Each faceValue In sourceDict.keys
  21.                 NofFaceValue = sourceDict(faceValue)
  22.                 sourceDict.Remove (faceValue)
  23.                 For divsor = 2 To 4
  24.                     changedCoin = faceValue \ divsor
  25.                     If changedCoin < 40 Then
  26.                         Select Case changedCoin
  27.                             Case 24, 32, 33
  28.                                 matchCoin = changedCoin + 3
  29.                             Case 25, 28, 30, 34
  30.                                 matchCoin = changedCoin + 2
  31.                             Case 12, 16, 18, 20, 21, 22, 26, 27, 29, 31, 35
  32.                                 matchCoin = changedCoin + 1
  33.                             Case 36 To 39
  34.                                 matchCoin = 41
  35.                             Case Else
  36.                                 matchCoin = changedCoin

  37.                         End Select
  38.                         aRes(coinIndex) = aRes(coinIndex) + matchCoin * NofFaceValue
  39.                     Else
  40.                         sourceDict(changedCoin) = sourceDict(changedCoin) + NofFaceValue
  41.                     End If
  42.                 Next
  43.             Next
  44.         Wend
  45.         coinIndex = coinIndex + 1
  46.     Next
  47.     ' 可更改结束
  48.     Set sourceDict = Nothing
  49.     ' 可更改结束
  50.     Debug.Print "ID: " & "<JsXjd>"
  51.     Debug.Print "Result: " & Join(aRes, ", ")
  52.     Debug.Print "Time: " & Format(Timer - t, "0.000s")
  53. End Sub
复制代码
' 对面值未作特殊处理,代码比较简洁
' 在原数组的基础上添加 10 ^ 9 和 30000,循环 100 次稳定在 0.5 秒
  1. Sub ChangeCoin_JsXjd2()
  2.     Dim aCoins(), aRes(), nCoin, t#
  3.     ' 可更改段
  4.     ' 只能是Dim
  5.     Dim sourceDict, faceValue
  6.     Dim coinIndex&, NofFaceValue&, divsor&, changedCoin&, matchCoin&
  7.     ' 可更改结束
  8.     aCoins = Array(12, 123, 1000, 50000, 600000, 30000000, 10 ^ 9, 30000)
  9.     '                                                      =============
  10.     ReDim aRes(UBound(aCoins))
  11.     t = Timer
  12.     ' 可更改段
  13.     coinIndex = 0
  14.     Set sourceDict = CreateObject("Scripting.Dictionary")
  15.    ' 可更改段
  16.     For Each nCoin In aCoins
  17.         '....
  18.         sourceDict(nCoin) = 1
  19.         While sourceDict.Count > 0
  20.             For Each faceValue In sourceDict.keys
  21.                 NofFaceValue = sourceDict(faceValue)
  22.                 sourceDict.Remove (faceValue)
  23.                 For divsor = 2 To 4
  24.                     changedCoin = faceValue \ divsor
  25.                    If changedCoin < 12 Then
  26.                        aRes(coinIndex) = aRes(coinIndex) + changedCoin * NofFaceValue
  27.                     Else
  28.                         sourceDict(changedCoin) = sourceDict(changedCoin) + NofFaceValue
  29.                     End If
  30.                 Next
  31.             Next
  32.         Wend
  33.         coinIndex = coinIndex + 1
  34.     Next
  35.     ' 可更改结束
  36.     Set sourceDict = Nothing
  37.     ' 可更改结束
  38.     Debug.Print "ID: " & "<JsXjd2>"
  39.     Debug.Print "Result: " & Join(aRes, ", ")
  40.     Debug.Print "Time: " & Format(Timer - t, "0.000s")
  41. End Sub
复制代码

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-8-26 21:27 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 minjiwei 于 2013-8-27 16:23 编辑

运行时间11秒左右,不知道再如何优化了。期待答案。谢谢!



本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-8-27 10:31 | 显示全部楼层
  1. Option Explicit
  2. Dim d As Object
  3. Sub ChangeCoin()
  4.     Dim aCoins(), aRes(), nCoin, t#
  5.     Dim i%
  6.     aCoins = Array(12, 123, 1000, 50000, 600000, 30000000, 1000000000)
  7.     ReDim aRes(UBound(aCoins))
  8.     t = Timer
  9.     Set d = CreateObject("scripting.dictionary")
  10.     i = 0
  11.     For Each nCoin In aCoins
  12.         aRes(i) = Change(nCoin)
  13.         i = i + 1
  14.     Next
  15.     Set d = Nothing
  16.     Debug.Print "ID: " & "<delete_007>"
  17.     Debug.Print "Result: " & Join(aRes, ", ")
  18.     Debug.Print "Time: " & Format(Timer - t, "0.000s")
  19. End Sub
  20. Function Change(x)
  21.     Dim x1&, x2&, x3&
  22.     If d.exists(x) Then
  23.         Change = d(x)
  24.     Else
  25.         If x < 12 Then
  26.             Change = x
  27.         Else
  28.             x1 = Int(x / 2)
  29.             x2 = Int(x / 3)
  30.             x3 = Int(x / 4)
  31.             Change = Change(x1) + Change(x2) + Change(x3)
  32.         End If
  33.         d.Add x, Change
  34.     End If
  35. End Function
复制代码
首次参加VBA竞赛,死了不少脑细胞,深感VBA的强大。

评分

1

查看全部评分

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

本版积分规则

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

GMT+8, 2024-3-29 15:37 , Processed in 0.052940 second(s), 19 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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