[第96期]换硬币[已总结]

yuanhongly · 发表于 2013-8-10 19:37

本帖最后由 yuanhongly 于 2013-8-10 20:07 编辑

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

yuanhongly · 发表于 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]

xzk235 · 发表于 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]

hellohaha · 发表于 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

huahua2005 · 发表于 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

xiaofx11 · 发表于 2013-8-25 20:27

本帖最后由 xiaofx11 于 2013-8-25 20:31 编辑

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

Dim dic As New Dictionary
Sub ChangeCoin()
Dim aCoins(), aRes(), nCoin, t#, i As Long
aCoins = Array(12, 123, 1000, 50000, 600000, 30000000)
ReDim aRes(UBound(aCoins))
t = Timer
i = 0
For Each nCoin In aCoins
aRes(i) = xiaofx11(nCoin)
i = i + 1
dic.RemoveAll
Next
' 可更改结束
Debug.Print "ID: " & "xiaofx11"
Debug.Print "Result: " & Join(aRes, ", ")
Debug.Print "Time: " & Format(Timer - t, "0.000s")
End Sub
Public Function xiaofx11(ByVal x As Long) As Long
Dim temp2, temp3, temp4
If x \ 2 + x \ 3 + x \ 4 > x Then
'----------
If dic.Exists(x \ 2) Then
temp2 = dic(x \ 2)
Else
temp2 = xiaofx11(x \ 2)
End If
'----------
If dic.Exists(x \ 3) Then
temp3 = dic(x \ 3)
Else
temp3 = xiaofx11(x \ 3)
End If
'----------
If dic.Exists(x \ 4) Then
temp4 = dic(x \ 4)
Else
temp4 = xiaofx11(x \ 4)
End If
xiaofx11 = temp2 + temp3 + temp4
Else
xiaofx11 = x
End If
dic(x) = xiaofx11
End Function

复制代码

Bodhidharma · 发表于 2013-8-26 12:18

本帖最后由 Bodhidharma 于 2013-8-26 12:30 编辑

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

Sub ChangeCoin()
Dim aCoins(), aRes(), nCoin, t#
' 可更改段
Dim ansArray(0 To 10000), i, j, top, n(1 To 10000), stage(1 To 10000), ans
' 只能是Dim
' 可更改結束
aCoins = Array(12, 123, 1000, 50000, 600000, 30000000)
ReDim aRes(UBound(aCoins))
t = Timer
' 可更改段
For i = 0 To 10000
If i >= -Fix(-i / 2) - Fix(-i / 3) - Fix(-i / 4) Then
ansArray(i) = i
Else
ansArray(i) = ansArray(-Fix(-i / 2)) + ansArray(-Fix(-i / 3)) + ansArray(-Fix(-i / 4))
End If
Next
j = 0
For Each nCoin In aCoins
ans = 0
top = 1
n(top) = nCoin
stage(top) = 1
Do While top > 0
If stage(top) = 1 Then
stage(top) = 0
If n(top) >= 10000 Then
top = top + 1
stage(top) = 1
n(top) = -Fix(-n(top - 1) / 2)
top = top + 1
stage(top) = 1
n(top) = -Fix(-n(top - 2) / 3)
top = top + 1
stage(top) = 1
n(top) = -Fix(-n(top - 3) / 4)
End If
Else
If n(top) < 10000 Then
ans = ans + ansArray(n(top))
End If
top = top - 1
End If
Loop
aRes(j) = ans
j = j + 1
Next
' 可更改結束
Debug.Print "ID: " & "Bodhidharma"
Debug.Print "Result: " & Join(aRes, ", ")
Debug.Print "Time: " & Format(Timer - t, "0.000s")
End Sub

复制代码

jsxjd · 发表于 2013-8-26 21:11

' 2.66 GHz 2GM
' 对面值 <40 进行单独处理，速度略有提高，当然也可设置常量数组
' 在原数组的基础上添加 10 ^ 9 和 30000，循环 100 次稳定在 0.43 秒，平均 0.0043秒
' 10^9：平均 0.0022 秒

Sub ChangeCoin_JsXjd()
Dim aCoins(), aRes(), nCoin, t#
' 可更改段
' 只能是Dim
Dim sourceDict, faceValue
Dim coinIndex&, NofFaceValue&, divsor&, changedCoin&, matchCoin&
' 可更改结束
aCoins = Array(12, 123, 1000, 50000, 600000, 30000000, 10 ^ 9, 30000)
' =============
ReDim aRes(UBound(aCoins))
t = Timer
' 可更改段
coinIndex = 0
Set sourceDict = CreateObject("Scripting.Dictionary")
' 可更改段
For Each nCoin In aCoins
'....
sourceDict(nCoin) = 1
While sourceDict.Count > 0
For Each faceValue In sourceDict.keys
NofFaceValue = sourceDict(faceValue)
sourceDict.Remove (faceValue)
For divsor = 2 To 4
changedCoin = faceValue \ divsor
If changedCoin < 40 Then
Select Case changedCoin
Case 24, 32, 33
matchCoin = changedCoin + 3
Case 25, 28, 30, 34
matchCoin = changedCoin + 2
Case 12, 16, 18, 20, 21, 22, 26, 27, 29, 31, 35
matchCoin = changedCoin + 1
Case 36 To 39
matchCoin = 41
Case Else
matchCoin = changedCoin
End Select
aRes(coinIndex) = aRes(coinIndex) + matchCoin * NofFaceValue
Else
sourceDict(changedCoin) = sourceDict(changedCoin) + NofFaceValue
End If
Next
Next
Wend
coinIndex = coinIndex + 1
Next
' 可更改结束
Set sourceDict = Nothing
' 可更改结束
Debug.Print "ID: " & "<JsXjd>"
Debug.Print "Result: " & Join(aRes, ", ")
Debug.Print "Time: " & Format(Timer - t, "0.000s")
End Sub

复制代码

' 对面值未作特殊处理，代码比较简洁
' 在原数组的基础上添加 10 ^ 9 和 30000，循环 100 次稳定在 0.5 秒

Sub ChangeCoin_JsXjd2()
Dim aCoins(), aRes(), nCoin, t#
' 可更改段
' 只能是Dim
Dim sourceDict, faceValue
Dim coinIndex&, NofFaceValue&, divsor&, changedCoin&, matchCoin&
' 可更改结束
aCoins = Array(12, 123, 1000, 50000, 600000, 30000000, 10 ^ 9, 30000)
' =============
ReDim aRes(UBound(aCoins))
t = Timer
' 可更改段
coinIndex = 0
Set sourceDict = CreateObject("Scripting.Dictionary")
' 可更改段
For Each nCoin In aCoins
'....
sourceDict(nCoin) = 1
While sourceDict.Count > 0
For Each faceValue In sourceDict.keys
NofFaceValue = sourceDict(faceValue)
sourceDict.Remove (faceValue)
For divsor = 2 To 4
changedCoin = faceValue \ divsor
If changedCoin < 12 Then
aRes(coinIndex) = aRes(coinIndex) + changedCoin * NofFaceValue
Else
sourceDict(changedCoin) = sourceDict(changedCoin) + NofFaceValue
End If
Next
Next
Wend
coinIndex = coinIndex + 1
Next
' 可更改结束
Set sourceDict = Nothing
' 可更改结束
Debug.Print "ID: " & "<JsXjd2>"
Debug.Print "Result: " & Join(aRes, ", ")
Debug.Print "Time: " & Format(Timer - t, "0.000s")
End Sub

复制代码

minjiwei · 发表于 2013-8-26 21:27

本帖最后由 minjiwei 于 2013-8-27 16:23 编辑

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

delete_007 · 发表于 2013-8-27 10:31

Option Explicit
Dim d As Object
Sub ChangeCoin()
Dim aCoins(), aRes(), nCoin, t#
Dim i%
aCoins = Array(12, 123, 1000, 50000, 600000, 30000000, 1000000000)
ReDim aRes(UBound(aCoins))
t = Timer
Set d = CreateObject("scripting.dictionary")
i = 0
For Each nCoin In aCoins
aRes(i) = Change(nCoin)
i = i + 1
Next
Set d = Nothing
Debug.Print "ID: " & "<delete_007>"
Debug.Print "Result: " & Join(aRes, ", ")
Debug.Print "Time: " & Format(Timer - t, "0.000s")
End Sub
Function Change(x)
Dim x1&, x2&, x3&
If d.exists(x) Then
Change = d(x)
Else
If x < 12 Then
Change = x
Else
x1 = Int(x / 2)
x2 = Int(x / 3)
x3 = Int(x / 4)
Change = Change(x1) + Change(x2) + Change(x3)
End If
d.Add x, Change
End If
End Function

复制代码

首次参加VBA竞赛，死了不少脑细胞，深感VBA的强大。

		自动登录	找回密码
密码			免费注册

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

评分

评分

评分

本帖子中包含更多资源

评分

本帖子中包含更多资源

评分

本帖子中包含更多资源

评分

本帖子中包含更多资源

评分

评分