[已解决]VBA实现九个数字分成二组

vbyou127

VBA实现九个数字分成二组



将1、2、3、4、5、6、7、8、9九个数字分成二组，每个数字只能用一次，一组形成一个5位数，
另一组形成一个4位数，使得前者为后者的n倍。求所有满足条件的5位数和4位数。
(注意：N的最大值等于68,68以内的某些N也是不可能的。
不可能的N值包括：1、10、11、20、21、25、30、31等共32个。)



被除数从最小的可能值12345开始，递增，要判断被除数的正确性（无重复数字且不含0），
然后用剩下的4个数来组成除数，再两者相除，如果能够整除，则输出。

最佳答案

月排行榜 / 总排行榜

grf1973

2016-4-24 17:19

1. Sub test()
   
2.     Dim k&, k1&, tms#, N&
   
3.     [a:b] = ""
   
4.     tms = Timer
   
5.     Dim xstr$, x$, a$, b$, c$, d$
   
6.     xstr = "123456789"
   
7.       
   
8.     For k = 12345 To 98765
   
9.         If Chk(k) Then
   
10.             x = xstr
    
11.             For i = 1 To 5
    
12.                 x = Replace(x, Mid(k, i, 1), "")
    
13.             Next
    
14.             For i = 1 To 4
    
15.                 For j = 1 To 4
    
16.                     For m = 1 To 4
    
17.                         If i <> j And i <> m And j <> m Then
    
18.                             a = Mid(x, i, 1): b = Mid(x, j, 1): c = Mid(x, m, 1)
    
19.                             d = Replace(Replace(Replace(x, a, ""), b, ""), c, "")
    
20.                             k1 = Val(a & b & c & d)
    
21.                              If k Mod k1 = 0 Then
    
22.                                  N = N + 1
    
23.                                  Cells(N, 1) = k / k1
    
24.                                  Cells(N, 2) = k & "÷" & k1
    
25.                              End If
    
26.                         End If
    
27.                     Next
    
28.                 Next
    
29.             Next
    
30.         End If
    
31.     Next
    
32.     [a1].Resize(N, 2).Sort key1:=[a1]
    
33.     MsgBox Format(Timer - tms, "0.000s ") & kk
    
34. End Sub
    
35. Function Chk(s) As Boolean
    
36.     Dim i&
    
37.     If InStr(s, "0") Then Exit Function
    
38.     For i = 1 To Len(s) - 1
    
39.         If InStr(i + 1, s, Mid(s, i, 1)) Then Exit Function
    
40.     Next
    
41.     Chk = True
    
42. End Function

复制代码

跳转到最佳答案楼层

grf1973

1. Sub test()
   
2.     Dim k&, k1&, tms#, N&
   
3.     [a:b] = ""
   
4.     tms = Timer
   
5.     Dim xstr$, x$, a$, b$, c$, d$
   
6.     xstr = "123456789"
   
7.       
   
8.     For k = 12345 To 98765
   
9.         If Chk(k) Then
   
10.             x = xstr
    
11.             For i = 1 To 5
    
12.                 x = Replace(x, Mid(k, i, 1), "")
    
13.             Next
    
14.             For i = 1 To 4
    
15.                 For j = 1 To 4
    
16.                     For m = 1 To 4
    
17.                         If i <> j And i <> m And j <> m Then
    
18.                             a = Mid(x, i, 1): b = Mid(x, j, 1): c = Mid(x, m, 1)
    
19.                             d = Replace(Replace(Replace(x, a, ""), b, ""), c, "")
    
20.                             k1 = Val(a & b & c & d)
    
21.                              If k Mod k1 = 0 Then
    
22.                                  N = N + 1
    
23.                                  Cells(N, 1) = k / k1
    
24.                                  Cells(N, 2) = k & "÷" & k1
    
25.                              End If
    
26.                         End If
    
27.                     Next
    
28.                 Next
    
29.             Next
    
30.         End If
    
31.     Next
    
32.     [a1].Resize(N, 2).Sort key1:=[a1]
    
33.     MsgBox Format(Timer - tms, "0.000s ") & kk
    
34. End Sub
    
35. Function Chk(s) As Boolean
    
36.     Dim i&
    
37.     If InStr(s, "0") Then Exit Function
    
38.     For i = 1 To Len(s) - 1
    
39.         If InStr(i + 1, s, Mid(s, i, 1)) Then Exit Function
    
40.     Next
    
41.     Chk = True
    
42. End Function

复制代码

香川群子

这个题目，还是递归排列计算速度快。

1. Dim c&(), k&, cnt&
   
2. Sub 检查整除递归排列算法() 'abcde mod fghi =0
   
3.     Dim i&, tms#
   
4.     [a1].CurrentRegion = ""
   
5.     tms = Timer
   
6.     ReDim c(1 To 9)
   
7.    
   
8.     k = 0: cnt = 0: Call dgPL("", "", 0)
   
9.     MsgBox Format(Timer - tms, "0.000s ") & k & "/" & cnt
   
10. End Sub
    
11. Sub dgPL(a$, b$, t&)
    
12.     Dim i&
    
13.     cnt = cnt + 1
    
14.     If t = 9 Then If a Mod b = 0 Then k = k + 1: Cells(k, 1) = a: Cells(k, 2) = b
    
15.     For i = 1 To 9
    
16.         If c(i) = 0 Then
    
17.             c(i) = 1
    
18.             If t < 5 Then Call dgPL(a & i, b, t + 1) Else Call dgPL(a, b & i, t + 1)
    
19.             c(i) = 0
    
20.         End If
    
21.     Next
    
22. End Sub

复制代码

代码结构简单。

grf1973

一开始想得太复杂了。

1. Sub test()
   
2.     Dim k%, k1$, tms#, N&, j%
   
3.     [a:b] = ""
   
4.     tms = Timer
   
5.     Dim arr(1 To 1000, 1 To 1)
   
6.     For N = 2 To 80 '最大为98765/1234=80
   
7.         For k = 1234 To 9876
   
8.             cnt = cnt + 1
   
9.             If Chk(k) Then
   
10.                 k1 = CStr(N * k)
    
11.                 If Len(k1) = 5 Then
    
12.                     If Chk(k & k1) Then
    
13.                         j = j + 1
    
14.                         arr(j, 1) = N & "=" & k1 & "÷" & k
    
15.                     End If
    
16.                 End If
    
17.             End If
    
18.         Next
    
19.     Next
    
20.     [a1].Resize(j, 1) = arr
    
21.     MsgBox Format(Timer - tms, "0.000s ") & "    " & j & "/" & cnt
    
22. End Sub
    
23. Function Chk(s) As Boolean
    
24.     Dim i%
    
25.     If InStr(s, "0") Then Exit Function
    
26.     For i = 1 To Len(s) - 1
    
27.         If InStr(i + 1, s, Mid(s, i, 1)) Then Exit Function
    
28.     Next
    
29.     Chk = True
    
30. End Function

复制代码

香川群子

grf1973 发表于 2016-4-25 14:01
一开始想得太复杂了。

嗯，这个思路有道理。

帮你改一下代码，速度又提高不少。

1. Sub test3() 'by grf1973
   
2.     Dim j&, k&, k1&, N&, tms#
   
3.     [a:b] = "": tms = Timer
   
4.     For N = 2 To 80 '98765/1234=80
   
5.         For k = 1234 To 9876
   
6.             k1 = N * k
   
7.             If k1 > 10000 Then If Chk(k & k1) Then j = j + 1: Cells(j, 1) = k1: Cells(j, 2) = k
   
8.         Next
   
9.     Next
   
10.     MsgBox Format(Timer - tms, "0.000s ") & j
    
11. End Sub

复制代码