用VBA解欧拉计划题目（43）

grf1973

第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

pengyx

1、找出所有能被2、3、5、7、11、13、17整除三位数（三位无生复数）
2、从2到17找后两位等于前两位的数
3、求和
当然第二步可以剔枝。这是我想到的方法。

香川群子

检查并记录能整除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
    

复制代码

香川群子

结果正确：
4160357289
1460357289
4106357289
1406357289
4130952867
1430952867

总和=16695334890

香川群子

显然可以用递归检查。

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
    

复制代码

这样代码简单一些。

grf1973

我只会用笨办法。
代码中的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

复制代码

grf1973

第29句用 res = res + Val(x)  即可，一开始怕溢出，用了大数计算，事实上用不着。

pengyx

被搞晕了，就乱写不过好象最后也正确
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

grf1973

第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

复制代码

大灰狼1976

用了字典。

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

复制代码