排列组合问题vba求助

蓝色仰望

1、1-13共13个数字
2、随机抽取7个数字排列组合
3、每相邻两个数字的差必须为（1-7）中的6种，不能重复
第三个要求意思就是相邻两数字的差从数字1到7中选6个作为差，但是不能重复，比如不能有两个差都是1这种，也不能有差是8,9这种


举个例子：
3  4   6   9   13   8   2

DevilW

1. Sub test()
   
2.     't 选7组合, s 差值, n 差组合
   
3.     Set reg = CreateObject("vbscript.regexp")
   
4.     reg.Global = True
   
5.     reg.Pattern = "\b(\d+)\b.*?\b\1\b"
   
6.     Dim br(1 To 120000, 1 To 7) '已跑一遍计数算出组合数量
   
7.     For i1 = 1 To 13
   
8.         For i2 = 1 To 13
   
9.             t1 = i1 & "," & i2: If reg.test(t1) Then GoTo npi2 '7组合重复跳
   
10.             s1 = Abs(i1 - i2): If s1 > 7 Then GoTo npi2 '差值>7跳
    
11.             For i3 = 1 To 13
    
12.                 t2 = t1 & "," & i3: If reg.test(t2) Then GoTo npi3
    
13.                 s2 = Abs(i3 - i2): If s2 > 7 Then GoTo npi3
    
14.                 n1 = s1 & "," & s2: If reg.test(n1) Then GoTo npi3 '差组合重复跳
    
15.                 For i4 = 1 To 13
    
16.                     t3 = t2 & "," & i4: If reg.test(t3) Then GoTo npi4
    
17.                     s3 = Abs(i3 - i4): If s3 > 7 Then GoTo npi4
    
18.                     n2 = n1 & "," & s3: If reg.test(n2) Then GoTo npi4
    
19.                     For i5 = 1 To 13
    
20.                         t4 = t3 & "," & i5: If reg.test(t4) Then GoTo npi5
    
21.                         s4 = Abs(i5 - i4): If s4 > 7 Then GoTo npi5
    
22.                         n3 = n2 & "," & s4: If reg.test(n3) Then GoTo npi5
    
23.                         For i6 = 1 To 13
    
24.                             t5 = t4 & "," & i6: If reg.test(t5) Then GoTo npi6
    
25.                             s5 = Abs(i5 - i6): If s5 > 7 Then GoTo npi6
    
26.                             n4 = n3 & "," & s5: If reg.test(n4) Then GoTo npi6
    
27.                             For i7 = 1 To 13
    
28.                                 t6 = t5 & "," & i7: If reg.test(t6) Then GoTo npi7
    
29.                                 s6 = Abs(i7 - i6): If s6 > 7 Then GoTo npi7
    
30.                                 n5 = n4 & "," & s6: If reg.test(n5) Then GoTo npi7
    
31. '==========================================================
    
32.                                 n = n + 1
    
33.                                 br(n, 1) = i1
    
34.                                 br(n, 2) = i2
    
35.                                 br(n, 3) = i3
    
36.                                 br(n, 4) = i4
    
37.                                 br(n, 5) = i5
    
38.                                 br(n, 6) = i6
    
39.                                 br(n, 7) = i7
    
40. '==========================================================
    
41. npi7:
    
42.                             Next
    
43. npi6:
    
44.                         Next
    
45. npi5:
    
46.                     Next
    
47. npi4:
    
48.                 Next
    
49. npi3:
    
50.             Next
    
51. npi2:
    
52.         Next
    
53.     Next
    
54.     [a1].Resize(n, 7) = br
    
55. End Sub

复制代码

yjh_27

共118296组

1. Sub aa()
   
2. Dim srr(1 To 120000, 1 To 7)
   
3. Dim brr(0 To 12)    '差值
   
4. Dim crr(1 To 13)    '元素
   
5. 
   
6. brr(0) = 1
   
7. For i = 8 To 12
   
8.     brr(i) = 1
   
9. Next
   
10. si = 0
    
11. For i1 = 1 To 13
    
12.     crr(i1) = 1
    
13. For i2 = 1 To 13
    
14.     If crr(i2) = 0 Then
    
15.     If brr(Abs(i2 - i1)) = 0 Then
    
16.     brr(Abs(i2 - i1)) = 1
    
17.     crr(i2) = 1
    
18. For i3 = 1 To 13
    
19.     If crr(i3) = 0 Then
    
20.     If brr(Abs(i3 - i2)) = 0 Then
    
21.     brr(Abs(i3 - i2)) = 1
    
22.     crr(i3) = 1
    
23. For i4 = 1 To 13
    
24.     If crr(i4) = 0 Then
    
25.     If brr(Abs(i4 - i3)) = 0 Then
    
26.     brr(Abs(i4 - i3)) = 1
    
27.     crr(i4) = 1
    
28. For i5 = 1 To 13
    
29.     If crr(i5) = 0 Then
    
30.     If brr(Abs(i5 - i4)) = 0 Then
    
31.     brr(Abs(i5 - i4)) = 1
    
32.     crr(i5) = 1
    
33. For i6 = 1 To 13
    
34.     If crr(i6) = 0 Then
    
35.     If brr(Abs(i6 - i5)) = 0 Then
    
36.     brr(Abs(i6 - i5)) = 1
    
37.     crr(i6) = 1
    
38. For i7 = 1 To 13
    
39.     If crr(i7) = 0 Then
    
40.     If brr(Abs(i7 - i6)) = 0 Then
    
41.         si = si + 1
    
42.         srr(si, 1) = i1
    
43.         srr(si, 2) = i2
    
44.         srr(si, 3) = i3
    
45.         srr(si, 4) = i4
    
46.         srr(si, 5) = i5
    
47.         srr(si, 6) = i6
    
48.         srr(si, 7) = i7
    
49.     End If
    
50.     End If
    
51. Next i7
    
52.     brr(Abs(i6 - i5)) = 0
    
53.     crr(i6) = 0
    
54.     End If
    
55.     End If
    
56. Next i6
    
57.     brr(Abs(i5 - i4)) = 0
    
58.     crr(i5) = 0
    
59.     End If
    
60.     End If
    
61. Next i5
    
62.     brr(Abs(i4 - i3)) = 0
    
63.     crr(i4) = 0
    
64.     End If
    
65.     End If
    
66. Next i4
    
67.     brr(Abs(i3 - i2)) = 0
    
68.     crr(i3) = 0
    
69.     End If
    
70.     End If
    
71. Next i3
    
72.     brr(Abs(i2 - i1)) = 0
    
73.     crr(i2) = 0
    
74.     End If
    
75.     End If
    
76. Next i2
    
77.     crr(i1) = 0
    
78. Next i1
    
79. 
    
80. Range("a1").Resize(si, 7) = srr
    
81. End Sub

复制代码

DevilW

118296组，不计次序

蓝色仰望

DevilW 发表于 2021-10-20 16:06
118296组，不计次序

感谢大神的帮助，谢谢

蓝色仰望

yjh_27 发表于 2021-10-20 16:02
共118296组

感谢大神的代码，谢谢