Excel精英培训网

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

[已解决]VBA计算出所有可能算式用完1-9有1个3

[复制链接]
发表于 2016-4-20 14:10 | 显示全部楼层 |阅读模式
VBA计算出所有可能算式用完1-9有1个3
最佳答案
2016-4-20 15:26
都采用直接循环计算法,数学计算结果再检查排除重复数字。
  1. Function Chk(s) As Boolean
  2.     Dim i&
  3.     If InStr(s, "0") Then Exit Function
  4.     For i = 1 To Len(s) - 1
  5.         If InStr(i + 1, s, Mid(s, i, 1)) Then Exit Function
  6.     Next
  7.     Chk = True
  8. End Function
  9. Sub test2() 'ab*cde=fghi /=7
  10.     Dim ab&, cde&, fghi&, k&, tms#
  11.     [b:b] = ""
  12.     tms = Timer
  13.    
  14.     For ab = 12 To 98
  15.         For cde = 123 To 987
  16.             fghi = ab * cde
  17.             If Len(CStr(fghi)) = 4 Then
  18.                 If Chk(ab & cde & fghi) Then
  19.                     k = k + 1: Cells(k, 2) = ab & "*" & cde & "=" & fghi
  20.                 End If
  21.             End If
  22.         Next
  23.     Next
  24.     MsgBox Format(Timer - tms, "0.000s ") & k
  25. End Sub
  26. Sub test3() 'a*bcd=ef*ghi /=13
  27.     Dim a&, bcd&, ef&, ghi&, k&, tms#
  28.     [c:c]
  29.     tms = Timer
  30.    
  31.     For a = 1 To 9
  32.         For bcd = 123 To 987
  33.             For ef = 12 To 98
  34.                 If a * bcd Mod ef = 0 Then
  35.                     ghi = a * bcd / ef
  36.                     If Len(CStr(ghi)) = 3 Then
  37.                         If Chk(a & bcd & ef & ghi) Then k = k + 1: Cells(k, 3) = a & "*" & bcd & "=" & ef & "*" & ghi
  38.                     End If
  39.                 End If
  40.             Next
  41.         Next
  42.     Next
  43.     MsgBox Format(Timer - tms, "0.000s ") & k
  44. End Sub
  45. Sub test4() 'a*bcd=e*fghi /=28
  46.     Dim a&, bcd&, e&, fghi&, k&, tms#
  47.     [d:d]
  48.     tms = Timer
  49.    
  50.     For a = 1 To 9
  51.         For bcd = 123 To 987
  52.             For e = 1 To 9
  53.                 If a * bcd Mod e = 0 Then
  54.                     fghi = a * bcd / e
  55.                     If Len(CStr(fghi)) = 4 Then
  56.                         If Chk(a & bcd & e & fghi) Then k = k + 1: Cells(k, 4) = a & "*" & bcd & "=" & e & "*" & fghi
  57.                     End If
  58.                 End If
  59.             Next
  60.         Next
  61.     Next
  62.     MsgBox Format(Timer - tms, "0.000s ") & k
  63. End Sub
复制代码
金山T盘,C语言趣味程序百例精解p76思考题5.jpg
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2016-4-20 15:26 | 显示全部楼层    本楼为最佳答案   
都采用直接循环计算法,数学计算结果再检查排除重复数字。
  1. Function Chk(s) As Boolean
  2.     Dim i&
  3.     If InStr(s, "0") Then Exit Function
  4.     For i = 1 To Len(s) - 1
  5.         If InStr(i + 1, s, Mid(s, i, 1)) Then Exit Function
  6.     Next
  7.     Chk = True
  8. End Function
  9. Sub test2() 'ab*cde=fghi /=7
  10.     Dim ab&, cde&, fghi&, k&, tms#
  11.     [b:b] = ""
  12.     tms = Timer
  13.    
  14.     For ab = 12 To 98
  15.         For cde = 123 To 987
  16.             fghi = ab * cde
  17.             If Len(CStr(fghi)) = 4 Then
  18.                 If Chk(ab & cde & fghi) Then
  19.                     k = k + 1: Cells(k, 2) = ab & "*" & cde & "=" & fghi
  20.                 End If
  21.             End If
  22.         Next
  23.     Next
  24.     MsgBox Format(Timer - tms, "0.000s ") & k
  25. End Sub
  26. Sub test3() 'a*bcd=ef*ghi /=13
  27.     Dim a&, bcd&, ef&, ghi&, k&, tms#
  28.     [c:c]
  29.     tms = Timer
  30.    
  31.     For a = 1 To 9
  32.         For bcd = 123 To 987
  33.             For ef = 12 To 98
  34.                 If a * bcd Mod ef = 0 Then
  35.                     ghi = a * bcd / ef
  36.                     If Len(CStr(ghi)) = 3 Then
  37.                         If Chk(a & bcd & ef & ghi) Then k = k + 1: Cells(k, 3) = a & "*" & bcd & "=" & ef & "*" & ghi
  38.                     End If
  39.                 End If
  40.             Next
  41.         Next
  42.     Next
  43.     MsgBox Format(Timer - tms, "0.000s ") & k
  44. End Sub
  45. Sub test4() 'a*bcd=e*fghi /=28
  46.     Dim a&, bcd&, e&, fghi&, k&, tms#
  47.     [d:d]
  48.     tms = Timer
  49.    
  50.     For a = 1 To 9
  51.         For bcd = 123 To 987
  52.             For e = 1 To 9
  53.                 If a * bcd Mod e = 0 Then
  54.                     fghi = a * bcd / e
  55.                     If Len(CStr(fghi)) = 4 Then
  56.                         If Chk(a & bcd & e & fghi) Then k = k + 1: Cells(k, 4) = a & "*" & bcd & "=" & e & "*" & fghi
  57.                     End If
  58.                 End If
  59.             Next
  60.         Next
  61.     Next
  62.     MsgBox Format(Timer - tms, "0.000s ") & k
  63. End Sub
复制代码

评分

参与人数 1 +9 收起 理由
vbyou127 + 9

查看全部评分

回复

使用道具 举报

发表于 2016-4-20 15:27 | 显示全部楼层
所有的结果:
4*679=2*13584*897=23*15612*483=5796
4*769=2*15387*538=14*26918*297=5346
4*793=2*15867*586=14*29327*198=5346
6*583=2*17497*638=29*15428*157=4396
6*729=3*14587*658=14*32939*186=7254
6*792=3*15847*984=56*12342*138=5796
6*927=3*18548*459=27*13648*159=7632
7*534=2*18698*759=46*132
7*986=2*34519*476=28*153
8*394=2*15769*534=18*267
8*439=2*17569*546=18*273
8*459=1*36729*654=18*327
8*469=1*37529*782=46*153
8*537=1*4296
8*579=1*4632
8*592=1*4736
8*674=1*5392
8*679=1*5432
8*742=1*5936
8*794=1*6352
8*932=1*7456
8*942=1*7536
8*953=1*7624
8*954=1*7632
9*582=3*1746
9*638=1*5742
9*647=1*5823
9*836=1*7524

评分

参与人数 1 +9 收起 理由
vbyou127 + 9 来学习

查看全部评分

回复

使用道具 举报

发表于 2016-4-20 16:17 | 显示全部楼层
共28组,
4*679=2*1358
4*769=2*1538
4*793=2*1586
8*459=1*3672
8*469=1*3752
6*583=2*1749
6*729=3*1458
6*792=3*1584
9*582=3*1746
6*927=3*1854
9*638=1*5742
7*534=2*1869
7*986=2*3451
8*394=2*1576
8*439=2*1756
8*537=1*4296
8*579=1*4632
8*592=1*4736
8*674=1*5392
8*679=1*5432
8*742=1*5936
8*794=1*6352
8*932=1*7456
8*942=1*7536
8*953=1*7624
8*954=1*7632
9*647=1*5823
9*836=1*7524
  1. Sub tt()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     Set d1 = CreateObject("scripting.dictionary")
  4.     For i = 1 To 9       '1*3
  5.         For j = 123 To 987
  6.             k = i * j
  7.             If Chk(i & j) Then d(k) = d(k) & "," & i & j
  8.         Next
  9.         
  10.         For j = 1234 To 9876   '1*4
  11.             k = i * j
  12.             If Chk(i & j) Then d1(k) = d1(k) & "," & i & j
  13.         Next
  14.     Next
  15.    
  16.     For Each k In d.keys
  17.         If d1.exists(k) Then
  18.             xrr = Split(d(k), ",")
  19.             yrr = Split(d1(k), ",")
  20.             For m = 1 To UBound(xrr)
  21.                 x = xrr(m)
  22.                 For n = 1 To UBound(yrr)
  23.                     y = yrr(n)
  24.                     If Chk(x & y) Then
  25.                         p = p + 1
  26.                         Cells(p, 1) = Left(x, 1) & "*" & Mid(x, 2) & "=" & Left(y, 1) & "*" & Mid(y, 2)
  27.                     End If
  28.                 Next
  29.             Next
  30.         End If
  31.     Next
  32. End Sub

  33. Function Chk(s) As Boolean
  34.     If InStr(s, "0") Then Exit Function
  35.     For i = 2 To Len(s)
  36.         If InStr(i, s, Mid(s, i - 1, 1)) Then Exit Function
  37.     Next
  38.     Chk = True
  39. End Function
复制代码

评分

参与人数 1 +9 收起 理由
vbyou127 + 9 来学习

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2016-4-20 16:19 | 显示全部楼层
香川群子 发表于 2016-4-20 15:27
所有的结果:

你没有必要太过认真



Sub s()
    Const a = "123456789"
    For i = 1 To 9
        b = Replace(a, i, "")
        p b, i, 1, 0
    Next
End Sub
Sub p(a, x, k, y)
    For i = 1 To Len(a)
        xx = Mid(a, i, 1)
        yy = y * 10 + Val(xx)
        b = Replace(a, xx, "")
        Z = x * yy
        If k = 3 Then
            For j = 1 To 5
                xx = Mid(b, j, 1)
                If Z Mod xx = 0 Then
                    zz = Z / xx
                    If zz < 10000 Then
                        c = Replace(b, xx, "")
                        For jj = 1 To 4
                            c = Replace(c, Mid(CStr(zz), jj, 1), "")
                        Next
                        If c = "" Then
                            Debug.Print x; "X"; yy; "="; xx; " X"; zz
                        End If
                    End If
                End If
            Next
        Else
            p b, x, k + 1, yy
        End If
     Next
End Sub


4 X 679 =2 X 1358
4 X 769 =2 X 1538
4 X 793 =2 X 1586
6 X 583 =2 X 1749
6 X 729 =3 X 1458
6 X 792 =3 X 1584
6 X 927 =3 X 1854
7 X 534 =2 X 1869
7 X 986 =2 X 3451
8 X 394 =2 X 1576
8 X 439 =2 X 1756
8 X 459 =1 X 3672
8 X 469 =1 X 3752
8 X 537 =1 X 4296
8 X 579 =1 X 4632
8 X 592 =1 X 4736
8 X 674 =1 X 5392
8 X 679 =1 X 5432
8 X 742 =1 X 5936
8 X 794 =1 X 6352
8 X 932 =1 X 7456
8 X 942 =1 X 7536
8 X 953 =1 X 7624
8 X 954 =1 X 7632
9 X 582 =3 X 1746
9 X 638 =1 X 5742
9 X 647 =1 X 5823
9 X 836 =1 X 7524









回复

使用道具 举报

发表于 2016-4-20 16:22 | 显示全部楼层
chk函数加个长度判断,速度可以提高1倍多
  1. Function Chk(s) As Boolean
  2.     If InStr(s, "0") Then Exit Function
  3.     If Len(s) <> 4 Then Exit Function
  4.     For i = 2 To Len(s)
  5.         If InStr(i, s, Mid(s, i - 1, 1)) Then Exit Function
  6.     Next
  7.     Chk = True
  8. End Function
复制代码
回复

使用道具 举报

发表于 2016-4-20 16:27 | 显示全部楼层
还是香川的代码,清清楚楚。
回复

使用道具 举报

发表于 2016-4-21 08:26 | 显示全部楼层
grf1973 发表于 2016-4-20 16:22
chk函数加个长度判断,速度可以提高1倍多

长度判断可以放在外面,没必要写在判断函数里。这样效率更高一些。



回复

使用道具 举报

发表于 2016-4-21 10:02 | 显示全部楼层
vbyou127 发表于 2016-4-20 16:19
你没有必要太过认真

按你的Replace递归算法思路,重新写了一遍。
  1. Sub test4()
  2.     Dim a, s$, ss$, tms#
  3.     tms = Timer
  4.     ss = "123456789"
  5.     For a = 1 To 9
  6.         s = Replace(ss, a, "")
  7.         Call dg(a, s, "", 0)
  8.     Next
  9.     MsgBox Format(Timer - tms, "0.000s ")
  10. End Sub
  11. Sub dg(a, s$, bcd, n&)
  12.     Dim e, fghi, i&, j&, k&, s2$, s3$, t$
  13.     If n < 3 Then
  14.         For i = 1 To Len(s)
  15.             t = Mid(s, i, 1)
  16.             Call dg(a, Replace(s, t, ""), bcd & t, n + 1)
  17.         Next
  18.     Else
  19.         For j = 1 To 5
  20.             e = Mid(s, j, 1)
  21.             If a * bcd Mod e = 0 Then
  22.                 fghi = a * bcd / e
  23.                 If Len(CStr(fghi)) = 4 Then
  24.                     s2 = Replace(s, e, "")
  25.                     For k = 1 To 4
  26.                         If InStr(fghi, Mid(s2, k, 1)) = 0 Then Exit For '用Instr检查效率高
  27.                     Next
  28.                     If k = 5 Then Debug.Print a; "* "; bcd; " = "; e; " *"; fghi: Exit For
  29.                     
  30. '                    For k = 1 To 4
  31. '                        s2 = Replace(s2, Mid(fghi, k, 1), "")
  32. '                    Next
  33. '                    If s2 = "" Then Debug.Print a; "* "; bcd; " = "; e; " *"; fghi: Exit For
  34.                 End If
  35.             End If
  36.         Next
  37.     End If
  38. End Sub
复制代码
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-28 19:41 , Processed in 0.404623 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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