每个单元格取一个数并组合起来

不可说7625

A1、A2、A3、A4、A5手动输入的值
在A7得出结果

例如

A1=15679
A2=13456
A3=02589
A4=12389
A5=03467

1、A7的结果是A1、A2、A3、A4、A5每个号分别取一个数合起来
11010 11013 11014 11016 11017以此类推
总共3125个



2、A8的结果是A1、A2、A3、A4、A5每个号分别取一个数合起来并排序，重复的删除
00111 01113 01114 01116 01117以此类推

3、加个按钮运行，谢谢

liulang0808

简单写法，5层for循环遍历即可
A8中的，使用字典去重

ykcbf1100

先完成第一部分吧。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.22
   
2.     ReDim brr(1 To 100000, 1 To 1), ar(1 To 5)
   
3.     With Sheets("Sheet1")
   
4.         arr = .[a1:a5]
   
5.         For i = 1 To UBound(arr)
   
6.             ar(i) = CStr(arr(i, 1))
   
7.         Next
   
8.         For num1 = 1 To 5
   
9.             st1 = Mid(ar(1), num1, 1)
   
10.             For num2 = 1 To 5
    
11.                 st2 = Mid(ar(2), num2, 1)
    
12.                 For num3 = 1 To 5
    
13.                     st3 = Mid(ar(3), num3, 1)
    
14.                     For num4 = 1 To 5
    
15.                         st4 = Mid(ar(4), num4, 1)
    
16.                         For num5 = 1 To 5
    
17.                             st5 = Mid(ar(5), num5, 1)
    
18.                             If Len(Join(Split(st1 & st2 & st3 & st4 & st5, ""), "")) = 5 Then
    
19.                                 m = m + 1
    
20.                                 st = st & Chr(10) & st1 & st2 & st3 & st4 & st5
    
21.                             End If
    
22.                         Next num5
    
23.                     Next num4
    
24.                 Next num3
    
25.             Next num2
    
26.         Next num1
    
27.         .[a7] = Mid(st, 2)
    
28.         MsgBox "共有" & m & "种组合！"
    
29.     End With
    
30. End Sub
    
31. 
    

复制代码

ykcbf1100

[a7]和[a8]单元格都写好了。

ykcbf1100

完整代码：

1. Sub ykcbf()  '//2024.4.22
   
2.     ReDim brr(1 To 100000, 1 To 1), ar(1 To 5)
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Dim c As New Collection
   
5.     With Sheets("Sheet1")
   
6.         arr = .[a1:a5]
   
7.         For i = 1 To UBound(arr)
   
8.             ar(i) = CStr(arr(i, 1))
   
9.         Next
   
10.         For num1 = 1 To 5
    
11.             st1 = Mid(ar(1), num1, 1)
    
12.             For num2 = 1 To 5
    
13.                 st2 = Mid(ar(2), num2, 1)
    
14.                 For num3 = 1 To 5
    
15.                     st3 = Mid(ar(3), num3, 1)
    
16.                     For num4 = 1 To 5
    
17.                         st4 = Mid(ar(4), num4, 1)
    
18.                         For num5 = 1 To 5
    
19.                             st5 = Mid(ar(5), num5, 1)
    
20.                             If Len(Join(Split(st1 & st2 & st3 & st4 & st5, ""), "")) = 5 Then
    
21.                                 m = m + 1
    
22.                                 st = st & Chr(10) & st1 & st2 & st3 & st4 & st5
    
23.                                 s = CStr(st1 & st2 & st3 & st4 & st5)
    
24.                                 If Not d.exists(s) Then
    
25.                                     c.Add s
    
26.                                 End If
    
27.                             End If
    
28.                         Next num5
    
29.                     Next num4
    
30.                 Next num3
    
31.             Next num2
    
32.         Next num1
    
33.         .[a7] = Mid(st, 2)
    
34.         ReDim br(1 To c.Count)
    
35.         For Each k In c
    
36.             n = n + 1
    
37.             br(n) = k
    
38.         Next
    
39.         sort1 br, True
    
40.         tst = ""
    
41.         For i = 1 To UBound(br)
    
42.             tst = tst & Chr(10) & br(i)
    
43.         Next
    
44.         MsgBox "共有" & m & "种组合！"
    
45.         .[a8] = Mid(tst, 2)
    
46.     End With
    
47.     MsgBox "OK！"
    
48. End Sub
    

复制代码

不可说7625

ykcbf1100 发表于 2024-4-22 15:52
完整代码：

A8的里面的结果，要按从小到大的顺序排，11010要排成00111，

ykcbf1100

不可说7625 发表于 2024-4-22 16:32
A8的里面的结果，要按从小到大的顺序排，11010要排成00111，

那你要把a3和a5排前面去

ykcbf1100

不可说7625 发表于 2024-4-22 16:32
A8的里面的结果，要按从小到大的顺序排，11010要排成00111，

按你的要求[a8]排好了。

ykcbf1100

这个用到了数组排序。

1. Sub ykcbf()  '//2024.4.22
   
2.     ReDim brr(1 To 100000, 1 To 1), ar(1 To 5)
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Dim c As New Collection
   
5.     With Sheets("Sheet1")
   
6.         arr = .[a1:a5]
   
7.         sort2 arr, 1, 1
   
8.         For i = 1 To UBound(arr)
   
9.             ar(i) = CStr(arr(i, 1))
   
10.         Next
    
11.         For num1 = 1 To 5
    
12.             st1 = Mid(ar(1), num1, 1)
    
13.             For num2 = 1 To 5
    
14.                 st2 = Mid(ar(2), num2, 1)
    
15.                 For num3 = 1 To 5
    
16.                     st3 = Mid(ar(3), num3, 1)
    
17.                     For num4 = 1 To 5
    
18.                         st4 = Mid(ar(4), num4, 1)
    
19.                         For num5 = 1 To 5
    
20.                             st5 = Mid(ar(5), num5, 1)
    
21.                             If Len(Join(Split(st1 & st2 & st3 & st4 & st5, ""), "")) = 5 Then
    
22.                                 m = m + 1
    
23.                                 st = st & Chr(10) & st1 & st2 & st3 & st4 & st5
    
24.                                 s = Val(st1 & st2 & st3 & st4 & st5)
    
25.                                 If Not d.exists(s) Then
    
26.                                     c.Add s
    
27.                                 End If
    
28.                             End If
    
29.                         Next num5
    
30.                     Next num4
    
31.                 Next num3
    
32.             Next num2
    
33.         Next num1
    
34.         .[a7] = Mid(st, 2)
    
35.         ReDim br(1 To c.Count)
    
36.         For Each k In c
    
37.             n = n + 1
    
38.             br(n) = k
    
39.         Next
    
40.         sort1 br, True
    
41.         For i = 1 To UBound(br)
    
42.             br(i) = Format(br(i), "00000")
    
43.         Next
    
44.         tst = ""
    
45.         For i = 1 To UBound(br)
    
46.             tst = tst & Chr(10) & br(i)
    
47.         Next
    
48.         MsgBox "共有" & m & "种组合！"
    
49.         .[a8] = Mid(tst, 2)
    
50.     End With
    
51.     MsgBox "OK！"
    
52. End Sub

复制代码