[已解决]筛选组合

mmc998

工作簿选六个.rar (17.32 KB, 下载次数: 26)

2015-2-27 19:59 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2015-2-27 20:42

1. Sub Macro1()
   
2. Dim arr, brr, w(9), i&, n%, j%, j2%, j3%, s%
   
3. [g:g] = ""
   
4. arr = Range("a2").CurrentRegion
   
5. ReDim brr(1 To UBound(arr), 1 To 1)
   
6. n = UBound(arr, 2)
   
7. For i = 1 To UBound(arr)
   
8.     s = 0
   
9.     For j = 1 To n - 3
   
10.         For j2 = j + 1 To n - 2
    
11.             For j3 = j2 + 1 To n - 1
    
12.                 For j4 = j3 + 1 To n
    
13.                     zf = arr(i, j) & arr(i, j2) & arr(i, j3) & arr(i, j4)
    
14.                     For k = 1 To 12
    
15.                         z = Mid$(zf, k, 1)
    
16.                         w(z) = z
    
17.                     Next
    
18.                     If Len(Join(w, "")) >= 8 Then s = s + 1 '不重复个数8
    
19.                     Erase w
    
20.                 Next
    
21.             Next
    
22.         Next
    
23.     Next
    
24.     If s =15 Then brr(i, 1) = "符合" '符合条件的组合个数
    
25. Next
    
26. Range("g2").Resize(UBound(brr)) = brr
    
27. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, w(9), i&, n%, j%, j2%, j3%, s%
   
3. [g:g] = ""
   
4. arr = Range("a2").CurrentRegion
   
5. ReDim brr(1 To UBound(arr), 1 To 1)
   
6. n = UBound(arr, 2)
   
7. For i = 1 To UBound(arr)
   
8.     s = 0
   
9.     For j = 1 To n - 3
   
10.         For j2 = j + 1 To n - 2
    
11.             For j3 = j2 + 1 To n - 1
    
12.                 For j4 = j3 + 1 To n
    
13.                     zf = arr(i, j) & arr(i, j2) & arr(i, j3) & arr(i, j4)
    
14.                     For k = 1 To 12
    
15.                         z = Mid$(zf, k, 1)
    
16.                         w(z) = z
    
17.                     Next
    
18.                     If Len(Join(w, "")) >= 8 Then s = s + 1 '不重复个数8
    
19.                     Erase w
    
20.                 Next
    
21.             Next
    
22.         Next
    
23.     Next
    
24.     If s =15 Then brr(i, 1) = "符合" '符合条件的组合个数
    
25. Next
    
26. Range("g2").Resize(UBound(brr)) = brr
    
27. End Sub

复制代码