[已解决]抽取数字组合

米特峰

组合.zip (10.39 KB, 下载次数: 15)

2014-11-27 09:53 上传

点击文件名下载附件
其实就是组合问题，麻烦老师们了

最佳答案

月排行榜 / 总排行榜

dsmch

2014-11-27 10:24

1. Sub Macro1()
   
2. dim arr,brr(1 to 60000,1 to 1)
   
3. arr = [r3:r5]
   
4. n = UBound(arr)
   
5. For i = 1 To n - 2
   
6.     For i2 = 1 To Len(arr(i, 1))
   
7.         s1 = Mid(arr(i, 1), i2, 1)
   
8.         For j = i + 1 To n - 1
   
9.             For j2 = 1 To Len(arr(j, 1))
   
10.                 s2 = Mid(arr(j, 1), j2, 1)
    
11.                 For k = j + 1 To n
    
12.                     For k2 = 1 To Len(arr(k, 1))
    
13.                         s3 = Mid(arr(k, 1), k2, 1)
    
14.                         s = s + 1
    
15.                         brr(s, 1) = "'" & s1 & s2 & s3
    
16.                     Next
    
17.                 Next
    
18.             Next
    
19.         Next
    
20.     Next
    
21. Next
    
22. Range("u1").Resize(s) = brr
    
23. End Sub

复制代码

跳转到最佳答案楼层

baksy

T1单元格复制一下公式，下拉；
=MID(R$3,INT((ROW()-1)/4)+1,1)&MID($R$4,INT((MOD(ROW()-1,4))/2)+1,1)&MID($R$5,MOD(ROW()-1,2)+1,1)

米特峰

baksy 发表于 2014-11-27 10:09
T1单元格复制一下公式，下拉；
=MID(R$3,INT((ROW()-1)/4)+1,1)&MID($R$4,INT((MOD(ROW()-1,4))/2)+1,1)&M ...

R3：R5我每个单元格都输入3个数字，这个公式就无效了，老师请用VBA，谢谢，

dsmch

1. Sub Macro1()
   
2. dim arr,brr(1 to 60000,1 to 1)
   
3. arr = [r3:r5]
   
4. n = UBound(arr)
   
5. For i = 1 To n - 2
   
6.     For i2 = 1 To Len(arr(i, 1))
   
7.         s1 = Mid(arr(i, 1), i2, 1)
   
8.         For j = i + 1 To n - 1
   
9.             For j2 = 1 To Len(arr(j, 1))
   
10.                 s2 = Mid(arr(j, 1), j2, 1)
    
11.                 For k = j + 1 To n
    
12.                     For k2 = 1 To Len(arr(k, 1))
    
13.                         s3 = Mid(arr(k, 1), k2, 1)
    
14.                         s = s + 1
    
15.                         brr(s, 1) = "'" & s1 & s2 & s3
    
16.                     Next
    
17.                 Next
    
18.             Next
    
19.         Next
    
20.     Next
    
21. Next
    
22. Range("u1").Resize(s) = brr
    
23. End Sub

复制代码

dsmch

………………

米特峰

1. Sub Macro1()
   
2. Range("T:T").ClearContents
   
3. Dim arr, brr(1 To 60000, 1 To 1)
   
4. arr = [r3:r5]
   
5. n = UBound(arr)
   
6. For i = 1 To n - 2
   
7.     For i2 = 1 To Len(arr(i, 1))
   
8.         s1 = Mid(arr(i, 1), i2, 1)
   
9.         For j = i + 1 To n - 1
   
10.             For j2 = 1 To Len(arr(j, 1))
    
11.                 s2 = Mid(arr(j, 1), j2, 1)
    
12.                 For k = j + 1 To n
    
13.                     For k2 = 1 To Len(arr(k, 1))
    
14.                         s3 = Mid(arr(k, 1), k2, 1)
    
15.                         s = s + 1
    
16.                         brr(s, 1) = "'" & s1 & s2 & s3
    
17.                     Next
    
18.                 Next
    
19.             Next
    
20.         Next
    
21.     Next
    
22. Next
    
23. Range("T1").Resize(s) = brr
    
24. End Sub

复制代码