自由列组合结果运算

longe1013

数据一	数据二	数据三	数据四	组合条件	结果
1	a	A	I	1:2
2	b	B	II	1:3:4
3	c	C	III	1:2:3:4
4	d	D	IV
5	e	E	V
6	f	F	VI

如上，我希望按照组合的自定义要求对前面四列的数据组合拼接在一起，1:2表示用第一列和第二列进行组合，如何把这三种组合的条件的结果计算出来并把结果放在【结果】列。求大师们帮忙看下，附件已上。举例条件1:2
1a
1b
1c
...
6f
举例条件1:2:3
1aA
1aB
1aC
...
6fF
同理，我需要把这三种的组合条件汇总在结果列，如何实现？
Sub 自由组合()
    num(0) = Sheet1.Cells(1, Columns.Count).End(1).Column
    If Sheet1.Cells(1, num(0)) <> "组合" Or Sheet1.Cells(Rows.Count, num(0)).End(3).Row < 2 Then
    MsgBox "请设定组合序列"
    Exit Sub
    End If
    For i = 2 To Sheet1.Cells(Rows.Count, num(0)).End(3).Row
        myarr = Split(Sheet1.Cells(i, num(0)), ":")
        num(1) = LBound(myarr)
        If num(1) >= 2 Then
            For j = 2 To Sheet1.Cells(1, myarr(0)).End(4).Row
                For k = 2 To Sheet1.Cells(1, myarr(1)).End(4).Row
                不知道怎么写下去了。。。
                Next
            Next
        End If
    Next
End Sub

上面我想写的，但是因为条件的组合列数不确定，所以不知道怎么写下去了，各位老师能帮忙看看吗？万谢！在线等。。。
组合求助.rar (6.48 KB, 下载次数: 9)

2016-6-16 12:49 上传

点击文件名下载附件

longe1013

自顶下 各位老师帮忙看看如何实现 如果用for循环因为组合的列数不确定有的时候是2列有的时候是3列，要怎么做呢？

longe1013

各位大虾 在线求助，帮忙看看把.

longe1013

唉，找了半天没人帮忙 自己做下来想了想，无意中想到了个方式，已经实现，了把代码贴出来记录下：

1. Sub 自由组合()
   
2.     Application.ScreenUpdating = False
   
3.     Dim num(0 To 8), i%, j%, k%, l%, s%
   
4.     Dim carr()
   
5.    
   
6.     num(0) = Sheet1.Cells(1, Columns.Count).End(1).Column
   
7.     Sheet1.Columns(num(0) + 1).Clear
   
8.     If Sheet1.Cells(1, num(0)) <> "组合" Or Sheet1.Cells(Rows.Count, num(0)).End(3).Row < 2 Then
   
9.     MsgBox "请设定组合序列"
   
10.     Exit Sub
    
11.     End If
    
12.    
    
13.     s = 1
    
14.     For i = 2 To Sheet1.Cells(Rows.Count, num(0)).End(3).Row
    
15.         myarr = Split(Sheet1.Cells(i, num(0)), ":")
    
16.         num(1) = UBound(myarr)
    
17.         If num(1) >= 1 Then
    
18.             For j = 0 To num(1) - 1
    
19.                 m = CInt(myarr(j))
    
20.                 n = CInt(myarr(j + 1))
    
21.                 If num(4) <> 1 Then
    
22.                     num(5) = Sheet1.Cells(Rows.Count, m).End(3).Row - 1
    
23.                     num(6) = num(5)
    
24.                     If num(5) < 2 Then num(5) = 2
    
25.                     aarr = Sheet1.Cells(2, m).Resize(num(5))
    
26.                 End If
    
27.                 If num(6) < 2 Then
    
28.                     num(2) = UBound(aarr) - 1
    
29.                 Else
    
30.                     num(2) = UBound(aarr)
    
31.                 End If
    
32.                 num(7) = Sheet1.Cells(Rows.Count, n).End(3).Row - 1
    
33.                 num(8) = num(7)
    
34.                 If num(7) < 2 Then num(7) = 2
    
35.                 barr = Sheet1.Cells(2, n).Resize(num(7))
    
36.                 If num(8) < 2 Then
    
37.                     num(3) = UBound(barr) - 1
    
38.                 Else
    
39.                     num(3) = UBound(barr)
    
40.                 End If
    
41.                 ReDim carr(1 To num(2) * num(3), 1 To 1)
    
42.                 For k = 1 To num(2)
    
43.                     For l = 1 To num(3)
    
44.                         carr(s, 1) = aarr(k, 1) & barr(l, 1)
    
45.                         s = s + 1
    
46.                     Next
    
47.                 Next
    
48.                 aarr = carr
    
49.                 num(6) = UBound(aarr)
    
50.                 If num(6) = 1 Then num(6) = 2
    
51.                 Erase carr
    
52.                 s = 1
    
53.                 num(4) = 1
    
54.             Next
    
55.         End If
    
56.     Sheet1.Cells(Sheet1.Cells(Rows.Count, num(0) + 1).End(3).Row + 1, num(0) + 1).Resize(UBound(aarr)) = aarr
    
57.     Erase aarr
    
58.     num(4) = 0
    
59.     Next
    
60.     MsgBox "组合完成！"
    
61.     Application.ScreenUpdating = True
    
62. End Sub

复制代码