[已解决]VBA如何实现十进制填数等式

vbyou127

VBA如何实现十进制填数等式

最佳答案

月排行榜 / 总排行榜

josonxu

2016-3-23 10:06

1. Sub tt()
   
2.     Sheet1.UsedRange.ClearContents
   
3.     Dim ar(1 To 362880), arr(1 To 362880, 1 To 3)
   
4.     For i = 1 To 9
   
5.         For o = 1 To 9
   
6.             If o <> i Then
   
7.                 For p = 1 To 9
   
8.                     If p <> i And p <> o Then
   
9.                         For j = 1 To 9
   
10.                             If j <> i And j <> o And j <> p Then
    
11.                                 For k = 1 To 9
    
12.                                     If k <> i And k <> o And k <> p And k <> j Then
    
13.                                         For l = 1 To 9
    
14.                                             If l <> i And l <> o And l <> p And l <> j And l <> k Then
    
15.                                                 For b = 1 To 9
    
16.                                                     If b <> i And b <> o And b <> p And b <> j And b <> k And b <> l Then
    
17.                                                         For n = 1 To 9
    
18.                                                             If n <> i And n <> o And n <> p And n <> j And n <> k And n <> l And n <> b Then
    
19.                                                                 For m = 1 To 9
    
20.                                                                     If m <> i And m <> o And m <> p And m <> j And m <> k And m <> l And m <> b And m <> n Then
    
21.                                                                         t = t + 1
    
22.                                                                         ar(t) = i & o & p & j & k & l & b & n & m
    
23.                                                                     End If
    
24.                                                                 Next
    
25.                                                             End If
    
26.                                                         Next
    
27.                                                     End If
    
28.                                                 Next
    
29.                                             End If
    
30.                                         Next
    
31.                                     End If
    
32.                                 Next
    
33.                             End If
    
34.                         Next
    
35.                     End If
    
36.                 Next
    
37.             End If
    
38.         Next
    
39.     Next
    
40.     For q = 1 To 362880
    
41.         If Val(VBA.Left(ar(q), 3)) + Val(VBA.Mid(ar(q), 4, 3)) = Val(VBA.Right(ar(q), 3)) Then
    
42.             w = w + 1
    
43.             arr(w, 1) = VBA.Left(ar(q), 3)
    
44.             arr(w, 2) = VBA.Mid(ar(q), 4, 3)
    
45.             arr(w, 3) = VBA.Right(ar(q), 3)
    
46.         End If
    
47.     Next
    
48.     Sheet1.Range("a1").Resize(362880, 3) = arr
    
49. End Sub
    

复制代码

跳转到最佳答案楼层

josonxu

1. Sub tt()
   
2.     Sheet1.UsedRange.ClearContents
   
3.     Dim ar(1 To 362880), arr(1 To 362880, 1 To 3)
   
4.     For i = 1 To 9
   
5.         For o = 1 To 9
   
6.             If o <> i Then
   
7.                 For p = 1 To 9
   
8.                     If p <> i And p <> o Then
   
9.                         For j = 1 To 9
   
10.                             If j <> i And j <> o And j <> p Then
    
11.                                 For k = 1 To 9
    
12.                                     If k <> i And k <> o And k <> p And k <> j Then
    
13.                                         For l = 1 To 9
    
14.                                             If l <> i And l <> o And l <> p And l <> j And l <> k Then
    
15.                                                 For b = 1 To 9
    
16.                                                     If b <> i And b <> o And b <> p And b <> j And b <> k And b <> l Then
    
17.                                                         For n = 1 To 9
    
18.                                                             If n <> i And n <> o And n <> p And n <> j And n <> k And n <> l And n <> b Then
    
19.                                                                 For m = 1 To 9
    
20.                                                                     If m <> i And m <> o And m <> p And m <> j And m <> k And m <> l And m <> b And m <> n Then
    
21.                                                                         t = t + 1
    
22.                                                                         ar(t) = i & o & p & j & k & l & b & n & m
    
23.                                                                     End If
    
24.                                                                 Next
    
25.                                                             End If
    
26.                                                         Next
    
27.                                                     End If
    
28.                                                 Next
    
29.                                             End If
    
30.                                         Next
    
31.                                     End If
    
32.                                 Next
    
33.                             End If
    
34.                         Next
    
35.                     End If
    
36.                 Next
    
37.             End If
    
38.         Next
    
39.     Next
    
40.     For q = 1 To 362880
    
41.         If Val(VBA.Left(ar(q), 3)) + Val(VBA.Mid(ar(q), 4, 3)) = Val(VBA.Right(ar(q), 3)) Then
    
42.             w = w + 1
    
43.             arr(w, 1) = VBA.Left(ar(q), 3)
    
44.             arr(w, 2) = VBA.Mid(ar(q), 4, 3)
    
45.             arr(w, 3) = VBA.Right(ar(q), 3)
    
46.         End If
    
47.     Next
    
48.     Sheet1.Range("a1").Resize(362880, 3) = arr
    
49. End Sub
    

复制代码

josonxu

文件加密 无法上传  复制代码即可

vbyou127

josonxu 发表于 2016-3-23 10:06

可惜结果错误，正确请看图片

josonxu

168 + 327 = 495  等等 这个答案里没有 它哪里错   全部只出现一次 1 2 3 4 5 6 7 8 9  是你的答案不全。

josonxu

336种（ a + b = c 、 b + a = c） 分别都算一种  

grf1973

共168组结果。

1. Sub tt()
   
2.     Dim arr(1 To 1000, 1 To 2)
   
3.     For a = 123 To 498
   
4.         If IsOK(a) Then
   
5.             For b = a + 1 To (987 - a)
   
6.                 If IsOK(b) And ISBH(a, b) = False Then
   
7.                     c = a + b
   
8.                     If IsOK(c) And ISBH(a & b, c) = False Then
   
9.                         n = n + 1
   
10.                         arr(n, 1) = n
    
11.                         arr(n, 2) = a & "+" & b & "=" & c
    
12.                     End If
    
13.                 End If
    
14.             Next
    
15.         End If
    
16.     Next
    
17.     If n > 0 Then [a1].Resize(n, 2) = arr
    
18. End Sub
    
19. Function IsOK(a) As Boolean   '判断一个三位数是否不含0，三位不重复
    
20.     IsOK = False
    
21.     If InStr(CStr(a), "0") = 0 Then
    
22.         a1 = Left(a, 1): a2 = Mid(a, 2, 1): a3 = Right(a, 1)
    
23.         If a1 <> a2 And a1 <> a3 And a2 <> a3 Then IsOK = True
    
24.     End If
    
25. End Function
    
26. Function ISBH(a, b) As Boolean    '判断三位数b的各位在a中有无出现过
    
27.     ISBH = True
    
28.     a = CStr(a)
    
29.     b1 = Left(b, 1): b2 = Mid(b, 2, 1): b3 = Right(b, 1)
    
30.     If InStr(a, b1) + InStr(a, b2) + InStr(a, b3) = 0 Then ISBH = False
    
31. End Function

复制代码

vbyou127

我也不知道，

josonxu

vbyou127 发表于 2016-3-23 17:01
我也不知道，

1 + 2 =3  2+1 =3  分别算个算一种  那就是336 种     如果算一种就是168 种

香川群子

grf1973 发表于 2016-3-23 16:58
共168组结果。

哈哈哈，是经过了简单数学剪枝缩小计算范围后的暴力破解算法，比较有趣。

我帮你简化一下，速度至少快1倍。

1. Sub test()
   
2.     tms = Timer
   
3.     For a = 123 To 498
   
4.         For b = a + 1 To 987 - a
   
5.             c = a + b
   
6.             If Chk(a & b & c) Then i = i + 1: Cells(i, 1) = a: Cells(i, 2) = b: Cells(i, 3) = c
   
7.         Next
   
8.     Next
   
9.     Debug.Print Format(Timer - tms, "0.000s "); i
   
10. End Sub
    
11. Function Chk(s$) As Boolean
    
12.     If InStr(s, "0") Then Exit Function '检查应不含0
    
13.     For i = 1 To 8
    
14.         If InStr(i + 1, s, Mid(s, i, 1)) Then Exit For '检查是否含重复数字
    
15.     Next
    
16.     If i = 9 Then Chk = True '9个数字都不重复时符合条件
    
17. End Function
    

复制代码

结果是168组。