Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

你正在寻找更好的Excel学习教程吗?Excel技巧80集+数据透视表+函数初中高全套+VBA80集,想学的这儿全都有
查看: 734|回复: 12

[分享] 用VBA解欧拉计划题目(43)

[复制链接]
发表于 2017-11-16 10:22 | 显示全部楼层 |阅读模式
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
第43题:子串的可整除性
1406357289是一个0至9全数字数,因为它由0到9这十个数字排列而成;但除此之外,它还有一个有趣的性质:子串的可整除性。
记d1是它的第一个数字,d2是第二个数字,依此类推,我们注意到:
  • d2d3d4=406能被2整除
  • d3d4d5=063能被3整除
  • d4d5d6=635能被5整除
  • d5d6d7=357能被7整除
  • d6d7d8=572能被11整除
  • d7d8d9=728能被13整除
  • d8d9d10=289能被17整除
找出所有满足同样性质的0至9全数字数,并求它们的和。

结果是16695334890

发表于 2017-11-16 15:09 | 显示全部楼层
1、找出所有能被2、3、5、7、11、13、17整除三位数(三位无生复数)
2、从2到17找后两位等于前两位的数
3、求和
当然第二步可以剔枝。这是我想到的方法。
回复 支持 反对

使用道具 举报

发表于 2017-11-17 17:06 | 显示全部楼层
本帖最后由 香川群子 于 2017-11-17 21:12 编辑


检查并记录能整除17的、且3个数各自不同的数值到一维数组a

同时,检查并记录其它可整除的不重复3位数数值,并按前2位数值作为关键词分类记录到三维数组b

最后,按数组a顺序,依次检查拼接对应的字符,
到拼接完成8个数字时,检查0-9中缺少的唯一一个数字,拼接于首位即可输出。

  1. Sub test() 'by kagawa 2017/11/17
  2.     Dim a&(999), b&(5, 99, 999)
  3.     tr = Array(2, 3, 5, 7, 11, 13, 17)
  4.     For i = 0 To 9
  5.         For j = 0 To 9
  6.             If j <> i Then
  7.                 For k = 0 To 9
  8.                     If k <> j And k <> i Then
  9.                         t = i * 100 + j * 10 + k
  10.                         If t Mod 17 = 0 Then
  11.                             m = a(0) + 1
  12.                             a(0) = m
  13.                             a(m) = t
  14.                         End If
  15.                         
  16.                         For l = 0 To 5
  17.                             n = tr(l)
  18.                             If t Mod n = 0 Then
  19.                                 t2 = j * 10 + k
  20.                                 m = b(l, t2, 0) + 1
  21.                                 b(l, t2, 0) = m
  22.                                 b(l, t2, m) = t
  23.                             End If
  24.                         Next
  25.                     End If
  26.                 Next
  27.             End If
  28.         Next
  29.     Next
  30.    
  31.     For i = 1 To a(0)
  32. '        If i = 13 Then Stop
  33.         s1 = Right("0" & a(i), 3)
  34.         t1 = Left(s1, 2)
  35.         For i1 = 1 To b(5, t1, 0)
  36.             s2 = Right("0" & b(5, t1, i1), 3)
  37.             t2 = Left(s2, 2)
  38.             For i2 = 1 To b(4, t2, 0)
  39.                 s3 = Right("0" & b(4, t2, i2), 3)
  40.                 t3 = Left(s3, 2)
  41.                 For i3 = 1 To b(3, t3, 0)
  42.                     s4 = Right("0" & b(3, t3, i3), 3)
  43.                     t4 = Left(s4, 2)
  44.                     For i4 = 1 To b(2, t4, 0)
  45.                         s5 = Right("0" & b(2, t4, i4), 3)
  46.                         t5 = Left(s5, 2)
  47.                         For i5 = 1 To b(1, t5, 0)
  48.                             s6 = Right("0" & b(1, t5, i5), 3)
  49.                             t6 = Left(s6, 2)
  50.                             For i6 = 1 To b(0, t6, 0)
  51.                                 s7 = Right("0" & b(0, t6, i6), 3)
  52.                                 t7 = Left(s7, 2)
  53.                                 
  54.                                 s = Left(s7, 1) & Left(s6, 1) & Left(s5, 1) & Left(s4, 1) & Left(s3, 1) & Left(s2, 1) & s1
  55.                                 t = 0: r = ""
  56.                                 For j = 0 To 9
  57.                                     If InStr(s, j) = 0 Then t = t + 1: r = r & j
  58.                                 Next
  59.                                 If t = 1 Then Debug.Print r & s
  60.                             Next
  61.                         Next
  62.                     Next
  63.                 Next
  64.             Next
  65.         Next
  66.     Next
  67.     Stop
  68. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2017-11-17 21:06 | 显示全部楼层
结果正确:
4160357289
1460357289
4106357289
1406357289
4130952867
1430952867

总和=16695334890
回复 支持 反对

使用道具 举报

发表于 2017-11-17 21:15 | 显示全部楼层
本帖最后由 香川群子 于 2017-11-17 21:30 编辑

显然可以用递归检查。
  1. Sub test() 'by kagawa 2017/11/17
  2.     Dim a&(999), b&(5, 99, 999)
  3.     tr = Array(2, 3, 5, 7, 11, 13, 17)
  4.     For i = 0 To 9
  5.       For j = 0 To 9
  6.         If j <> i Then
  7.           For k = 0 To 9
  8.             If k <> j And k <> i Then
  9.               t = i * 100 + j * 10 + k
  10.               If t Mod 17 = 0 Then m = a(0) + 1: a(0) = m: a(m) = t
  11.                
  12.               For l = 0 To 5
  13.                 n = tr(l)
  14.                 If t Mod n = 0 Then
  15.                   t2 = j * 10 + k
  16.                   m = b(l, t2, 0) + 1: b(l, t2, 0) = m: b(l, t2, m) = t
  17.                 End If
  18.               Next
  19.             End If
  20.           Next
  21.         End If
  22.       Next
  23.     Next
  24.    
  25.     For i = 1 To a(0)
  26.         s1 = Right("0" & a(i), 3)
  27.         Call dg(b, s1, 5, Left(s1, 2))
  28.     Next
  29.    
  30. End Sub
  31. Sub dg(b, s, n, t)
  32.     If n = -1 Then
  33.         k = 0: r = ""
  34.         For j = 0 To 9
  35.             If InStr(s, j) = 0 Then k = k + 1: r = r & j
  36.         Next
  37.         If k = 1 Then Debug.Print r & s
  38.         Exit Sub
  39.     End If
  40.     For i = 1 To b(n, t, 0)
  41.         s1 = Right(0 & b(n, t, i), 3)
  42.         Call dg(b, Left(s1, 1) & s, n - 1, Left(s1, 2))
  43.     Next
  44. End Sub
复制代码


这样代码简单一些。
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-11-17 21:50 | 显示全部楼层
我只会用笨办法。
代码中的Application.Max(d.items) = 1是用来检查是不是完全数的。

  1. Sub problem43()    '求出所有满足条件的0-9pandigit的和(条件:d234\2,d234\3,d456\5,d567\7,d678\11,d789\13,d8910\17  d234表示第2、3、4位组成的三位数)      结果是16695334890
  2.     Set d = CreateObject("scripting.dictionary")
  3.     Dim arr(1 To 10000, 1 To 1)
  4.     For i = 12345 To 987654    '先选出后六位的范围
  5.         x = Format(i, "000000")
  6.         If Val(Left(x, 3)) Mod 7 = 0 And Val(Mid(x, 2, 3)) Mod 11 = 0 And Val(Mid(x, 3, 3)) Mod 13 = 0 And Val(Mid(x, 4, 3)) Mod 17 = 0 Then
  7.             For k = 1 To 6
  8.                 d(Mid(x, k, 1)) = d(Mid(x, k, 1)) + 1
  9.             Next
  10.             If Application.Max(d.items) = 1 And d("5") + d("0") <= 1 Then
  11.                 s = s + 1
  12.                 arr(s, 1) = x
  13.             End If
  14.             d.RemoveAll
  15.         End If
  16.     Next
  17. '    '[a1].Resize(s) = arr
  18. '    arr = [a1].CurrentRegion
  19. '    s = UBound(arr)
  20.     For j = 1 To s   '再框定前4位
  21.         For i = 1024 To 9876 Step 2   '前4位最小1024开头,且步长为2(保证d234被2整除)
  22.             x = i & arr(j, 1)
  23.             If Val(Mid(x, 3, 3)) Mod 3 = 0 And (Mid(x, 6, 1) = "5" Or Mid(x, 6, 1) = "0") Then
  24.                 For k = 1 To 10
  25.                     d(Mid(x, k, 1)) = d(Mid(x, k, 1)) + 1
  26.                 Next
  27.                 If Application.Max(d.items) = 1 Then
  28.                     Debug.Print x
  29.                     res = LargeSum(res, x)
  30.                 End If
  31.                 d.RemoveAll
  32.             End If
  33.         Next
  34.     Next
  35.     Debug.Print res
  36. End Sub
复制代码
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-11-17 21:55 | 显示全部楼层
第29句用 res = res + Val(x)  即可,一开始怕溢出,用了大数计算,事实上用不着。
回复 支持 反对

使用道具 举报

发表于 2017-11-17 23:01 | 显示全部楼层
被搞晕了,就乱写不过好象最后也正确
Public br, cr, x, y, z, s,n, j, d, arr
Sub aa()
ReDim br(1 To 500, 7): ReDim cr(7, 9, 1): ReDim arr(1 To 100, 1 To 1)
ar = Array(2, 3, 5, 7, 11, 13, 17)
x = 0: y = 0: z = "": n = 0: j = 0: d = 0
For i = 0 To 6
    k = 0
    For j = 10 To 999
        a = Mid(j, 1, 1): b = Mid(j, 2, 1): c = Mid(j, 3, 1)
        If c = "" Then c = "0"
        If a <> b And b <> c And a <> c Then
            If j / ar(i) = Int(j / ar(i)) Then
                k = k + 1
                br(k, i) = Format(j, "000")
                cr(i, Val(Mid(br(k, i), 1, 1)), 0) = k
                cr(i, Val(Mid(br(k, i), 1, 1)), 1) = cr(i, Val(Mid(br(k, i), 1, 1)), 1) + 1
            End If
        End If
    Next
    If i = 0 Then n = k
Next
bb
End Sub
Sub bb()
j = 0
For i = 1 To n
    cc cr(1, Val(Mid(br(i, 0), 2, 1)), 1), 1, br(i, 0), cr(1, Val(Mid(br(i, 0), 2, 1)), 0)
Next
[h1] = j
[h2].Resize(d, 1) = arr
End Sub
Sub cc(x, y, z, s)
If y = 7 Then
    d = d + 1
    ReDim brr(9)
    For d1 = 1 To 10
        brr(Val(Mid(z, d1, 1))) = Val(Mid(z, d1, 1))
    Next
    For d2 = 0 To 9
        If brr(d2) = "" Then z = d2 & z
    Next
    arr(d, 1) = z
    j = j + Val(z)
End If
a = Left(Right(z, 2), 1): c = s - x + 1: b = Mid(br(c, y), 1, 1)
If a = b And y < 7 And Val(Right(z, 1)) >= Val(Mid(br(c, y), 2, 1)) Then
    If Right(z, 2) = Mid(br(c, y), 1, 2) And InStr(z, Mid(br(c, y), 3, 1)) = 0 Then
        cc cr(y + 1, Val(Mid(br(c, y), 2, 1)), 1), y + 1, z & Mid(br(c, y), 3, 1), cr(y + 1, Val(Mid(br(c, y), 2, 1)), 0)
    End If
    cc x - 1, y, z, s
End If
End Sub
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-11-18 12:22 | 显示全部楼层
第4句  For i = 12345 To 987654    '先选出后六位的范围
可以直接用17的倍数来代替,然后下面判断就可以少一个判断 mod 17的条件
这样速度提高 了10倍
  1. Sub problem43()    '求出所有满足条件的0-9pandigit的和(条件:d234\2,d234\3,d456\5,d567\7,d678\11,d789\13,d8910\17  d234表示第2、3、4位组成的三位数)      结果是16695334890
  2.     tm = Timer
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Dim arr(1 To 10000, 1 To 1)
  5.     For i = 12359 To 987654 Step 17    '先选出后六位的范围(只考虑17的倍数)
  6.         x = Format(i, "000000")
  7.         If Val(Left(x, 3)) Mod 7 = 0 And Val(Mid(x, 2, 3)) Mod 11 = 0 And Val(Mid(x, 3, 3)) Mod 13 = 0 Then            'And Val(Mid(x, 4, 3)) Mod 17 = 0 Then
  8.             For k = 1 To 6
  9.                 d(Mid(x, k, 1)) = d(Mid(x, k, 1)) + 1
  10.             Next
  11.             If Application.Max(d.items) = 1 And d("5") + d("0") <= 1 Then
  12.                 s = s + 1
  13.                 arr(s, 1) = x
  14.             End If
  15.             d.RemoveAll
  16.         End If
  17.     Next
  18. '    '[a1].Resize(s) = arr
  19. '    arr = [a1].CurrentRegion
  20. '    s = UBound(arr)
  21.     For j = 1 To s   '再框定前4位
  22.         For i = 1024 To 9876 Step 2   '前4位最小1024开头,且步长为2(保证d234被2整除)
  23.             x = i & arr(j, 1)
  24.             If Val(Mid(x, 3, 3)) Mod 3 = 0 And (Mid(x, 6, 1) = "5" Or Mid(x, 6, 1) = "0") Then
  25.                 For k = 1 To 10
  26.                     d(Mid(x, k, 1)) = d(Mid(x, k, 1)) + 1
  27.                 Next
  28.                 If Application.Max(d.items) = 1 Then
  29.                     Debug.Print x
  30.                     'res = LargeSum(res, x)
  31.                     res = res + Val(x)
  32.                 End If
  33.                 d.RemoveAll
  34.             End If
  35.         Next
  36.     Next
  37.     Debug.Print res, Timer - tm
  38. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2017-11-29 14:33 | 显示全部楼层
用了字典。
  1. Sub aaa()
  2. Dim arr, i&, j&, k&, l&, r&, s$, d As Object, n&, m&
  3. Set d = CreateObject("scripting.dictionary")
  4. arr = Array(13, 11, 7, 5, 3, 2)
  5. For i = 17 To 987 Step 17
  6.   j = i \ 100: k = (i Mod 100) \ 10: l = i Mod 10
  7.   If j <> k And j <> l And k <> l Then
  8.     s = j & k & l
  9.     If InStr(s, "0") = 0 Or InStr(s, "5") = 0 Then d(s) = ""
  10.   End If
  11. Next i
  12. For i = 0 To UBound(arr)
  13.   For Each c In d.keys
  14.     For j = 0 To 9
  15.       If InStr(c, j) = 0 Then
  16.         s = j & Left(c, 2)
  17.         If s Mod arr(i) = 0 Then d(j & c) = ""
  18.       End If
  19.     Next j
  20.     d.Remove c
  21.   Next c
  22. Next i
  23. For Each c In d.keys
  24.   For i = 0 To 9
  25.     If Not InStr(c, i) Then n = n + Val(i & c): Exit For
  26.   Next i
  27. Next c
  28. MsgBox n
  29. End Sub
复制代码
回复 支持 反对

使用道具 举报

*滑块验证:
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2018-10-19 04:12 , Processed in 0.078000 second(s), 12 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

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