[已解决]用VBA数组定位全排列输出结果

laoau138

用VBA数组定位全排列输出结果

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-4-15 20:04

是的，忘记加条件了

1. Sub aaa()
   
2. Dim arr, brr, i&, j&, k&, r&, c&
   
3. arr = [a1].CurrentRegion
   
4. r = 1
   
5. ReDim brr(1 To -Int(-((UBound(arr) - 1) ^ UBound(arr, 2)) / 10), 1 To 10)
   
6. For i = 2 To UBound(arr)
   
7.   If arr(i, 1) = "" Then Exit For
   
8.   For j = 2 To UBound(arr)
   
9.     If arr(j, 2) = "" Then Exit For
   
10.     For k = 2 To UBound(arr)
    
11.       If arr(k, 3) = "" Then Exit For
    
12.       c = c + 1
    
13.       If c = 11 Then
    
14.         c = 1
    
15.         r = r + 1
    
16.       End If
    
17.       brr(r, c) = arr(i, 1) & arr(j, 2) & arr(k, 3)
    
18.     Next k
    
19.   Next j
    
20. Next i
    
21. [a16].Resize(UBound(brr), 10) = brr
    
22. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

1. Sub aaa()
   
2. Dim arr, brr, i&, j&, k&, r&, c&
   
3. arr = [a1].CurrentRegion
   
4. r = 1
   
5. ReDim brr(1 To -Int(-((UBound(arr) - 1) ^ UBound(arr, 2)) / 10), 1 To 10)
   
6. For i = 2 To UBound(arr)
   
7.   For j = 2 To UBound(arr)
   
8.     For k = 2 To UBound(arr)
   
9.       c = c + 1
   
10.       If c = 11 Then
    
11.         c = 1
    
12.         r = r + 1
    
13.       End If
    
14.       brr(r, c) = arr(i, 1) & arr(j, 2) & arr(k, 3)
    
15.     Next k
    
16.   Next j
    
17. Next i
    
18. [a16].Resize(UBound(brr), 10) = brr
    
19. End Sub

复制代码

laoau138

大灰狼1976 发表于 2017-4-15 19:48

这几列数字，数字个数不确定可以变动,   

结果不对  每一个单元格输出都有3个数字才对

laoau138

大灰狼1976 发表于 2017-4-15 19:48

请再看一次

大灰狼1976

是的，忘记加条件了

1. Sub aaa()
   
2. Dim arr, brr, i&, j&, k&, r&, c&
   
3. arr = [a1].CurrentRegion
   
4. r = 1
   
5. ReDim brr(1 To -Int(-((UBound(arr) - 1) ^ UBound(arr, 2)) / 10), 1 To 10)
   
6. For i = 2 To UBound(arr)
   
7.   If arr(i, 1) = "" Then Exit For
   
8.   For j = 2 To UBound(arr)
   
9.     If arr(j, 2) = "" Then Exit For
   
10.     For k = 2 To UBound(arr)
    
11.       If arr(k, 3) = "" Then Exit For
    
12.       c = c + 1
    
13.       If c = 11 Then
    
14.         c = 1
    
15.         r = r + 1
    
16.       End If
    
17.       brr(r, c) = arr(i, 1) & arr(j, 2) & arr(k, 3)
    
18.     Next k
    
19.   Next j
    
20. Next i
    
21. [a16].Resize(UBound(brr), 10) = brr
    
22. End Sub

复制代码

laoau138

大灰狼1976 发表于 2017-4-15 20:04
是的，忘记加条件了

果然是高手