求单元格数据全排列的vba程序

CAONI

1、在b2开始的b列各单元格中分别填有不同的数据、各数据间空一格，
2、写出b列各单元格每组数据的全排列并依次输入到从d2开始的d列各单元格中且各数据间空一格，当d列填写完后就自动换列到从e2开始的e列，依次类推，
3、例如：b2单元格的数据:1 2 3 的全排列填在d2开始的d2-d7单元格，那么b3单元格的数据：4 5 6 7 的全排列就从d8开始填直到d31，b4单元格的数据：3 1 3 5 7 的全排列就从d32开始填直到d91，当d列填写完后就自动换到从e2开始的e列，

谢谢 ！
数据排序.zip (10.54 KB, 下载次数: 43)

2012-10-5 22:48 上传

点击文件名下载附件

zhaogang1960

有点难度:

1. Dim aStr As Variant, crr() As String
   
2. 
   
3. Sub 宏1()
   
4.     Dim arr() As String, brr
   
5.     Dim s As String, n As Integer, i As Long, r As Long
   
6.     brr = Range("b2:b" & Range("b" & Rows.count).End(xlUp).Row)
   
7.     [d:d].ClearContents
   
8.     For i = 1 To UBound(brr)
   
9.         s = brr(i, 1)
   
10.         n = (Len(s) + 1) / 2
    
11.         r = Application.Permut(n, n)
    
12.         ReDim arr(1 To r)
    
13.         ReDim crr(1 To r, 1 To 1)
    
14.         aStr = Split(s)
    
15.         getall n - 1, n, "", arr, 0
    
16.         Range("d" & Rows.count).End(xlUp).Offset(1).Resize(r) = crr
    
17.     Next
    
18. End Sub
    
19. 
    
20. Sub getall(ByVal m As Integer, ByVal n As Integer, ByRef a As String, ByRef arr() As String, Optional ByRef count As Long)
    
21.     Dim i As Long, j As Long, s As String
    
22.     If Len(a) = n Then
    
23.         count = count + 1
    
24.         arr(count) = a
    
25.         s = ""
    
26.         For j = 1 To n
    
27.             s = s & " " & aStr(Mid(a, j, 1))
    
28.         Next
    
29.         crr(count, 1) = Mid(s, 2)
    
30.         Exit Sub
    
31.     End If
    
32.     For i = 0 To m
    
33.         If InStr(a, i) = 0 Then getall m, n, a & i, arr, count
    
34.     Next i
    
35. End Sub

复制代码

zhaogang1960

请看附件
数据排序.rar (26.51 KB, 下载次数: 57)

2012-10-6 01:01 上传

点击文件名下载附件

win2009

1. '翻译一下
   
2. '注：只翻译最接近【最佳答案】和有【疑问】的帖子
   
3. 有点难度:
   
4. Dim aStr As Variant, crr() As String
   
5. Sub 宏1()
   
6.     Dim arr() As String, brr
   
7.     Dim s As String, n As Integer, i As Long, r As Long
   
8.     brr = Range("b2:b" & Range("b" & Rows.count).End(xlUp).Row)
   
9.     [d:d].ClearContents
   
10.     For i = 1 To UBound(brr)
    
11.         s = brr(i, 1)
    
12.         n = (Len(s) + 1) / 2
    
13.         r = Application.Permut(n, n)
    
14.         ReDim arr(1 To r)
    
15.         ReDim crr(1 To r, 1 To 1)
    
16.         aStr = Split(s)
    
17.         getall n - 1, n, "", arr, 0
    
18.         Range("d" & Rows.count).End(xlUp).Offset(1).Resize(r) = crr
    
19.     Next
    
20. End Sub
    
21. Sub getall(ByVal m As Integer, ByVal n As Integer, ByRef a As String, ByRef arr() As String, Optional ByRef count As Long)
    
22.     Dim i As Long, j As Long, s As String
    
23.     If Len(a) = n Then
    
24.         count = count + 1
    
25.         arr(count) = a
    
26.         s = ""
    
27.         For j = 1 To n
    
28.             s = s & " " & aStr(Mid(a, j, 1))
    
29.         Next
    
30.         crr(count, 1) = Mid(s, 2)
    
31.         Exit Sub
    
32.     End If
    
33.     For i = 0 To m
    
34.         If InStr(a, i) = 0 Then getall m, n, a & i, arr, count
    
35.     Next i
    
36. End Sub
    
37. 普通浏览复制代码保存代码打印代码
    
38. Dim aStr As Variant, crr() As String
    
39. Sub 宏1()
    
40.     Dim arr() As String, brr
    
41.     Dim s As String, n As Integer, i As Long, r As Long
    
42.     brr = Range("b2:b" & Range("b" & Rows.count).End(xlUp).Row)
    
43.     [d:d].ClearContents
    
44.     For i = 1 To UBound(brr)
    
45.         s = brr(i, 1)
    
46.         n = (Len(s) + 1) / 2
    
47.         r = Application.Permut(n, n)
    
48.         ReDim arr(1 To r)
    
49.         ReDim crr(1 To r, 1 To 1)
    
50.         aStr = Split(s)
    
51.         getall n - 1, n, "", arr, 0
    
52.         Range("d" & Rows.count).End(xlUp).Offset(1).Resize(r) = crr
    
53.     Next
    
54. End Sub
    
55. Sub getall(ByVal m As Integer, ByVal n As Integer, ByRef a As String, ByRef arr() As String, Optional ByRef count As Long)
    
56.     Dim i As Long, j As Long, s As String
    
57.     If Len(a) = n Then
    
58.         count = count + 1
    
59.         arr(count) = a
    
60.         s = ""
    
61.         For j = 1 To n
    
62.             s = s & " " & aStr(Mid(a, j, 1))
    
63.         Next
    
64.         crr(count, 1) = Mid(s, 2)
    
65.         Exit Sub
    
66.     End If
    
67.     For i = 0 To m
    
68.         If InStr(a, i) = 0 Then getall m, n, a & i, arr, count
    
69.     Next i
    
70. End Sub
    
71. 
    
72. 
    
73. 有点难度:
    
74. 定义变量 为tr 为 变体数据类型 ,crr() 为 字符串
    
75. 过程 宏1()
    
76.     定义变量 arr() 为 字符串 ,brr
    
77.     定义变量 s 为 字符串 ,n 为 整型值 ,i 为 长整型值 ,r 为 长整型值
    
78.     brr = 单元格区域("b2:b" & 单元格区域("b" & 行数 . 计数值) . 结束(方向向上) . 行标)
    
79.     [d:d] . 清除内容
    
80.     循环范围 i = 1 到 数组上限(brr)
    
81.         s = brr(i ,1)
    
82.         n = (字符串长度(s) + 1) / 2
    
83.         r = 应用程序 . permut(n ,n)
    
84.         重定义变量 arr(1 到 r)
    
85.         重定义变量 crr(1 到 r ,1 到 1)
    
86.         astr = 分割字符串(s)
    
87.         getall n - 1 ,n ,"" ,arr ,0
    
88.         单元格区域("d" & 行数 . 计数值) . 结束(方向向上) . 偏移(1) . 重调大小(r) = crr
    
89.     下一句
    
90. 结束 过程
    
91. 过程 getall(传值变量 m 为 整型值 ,传值变量 n 为 整型值 ,传址 a 为 字符串 ,传址 arr() 为 字符串 ,选择 传址 计数值 为 长整型值)
    
92.     定义变量 i 为 长整型值 ,j 为 长整型值 ,s 为 字符串
    
93.     如果 字符串长度(a) = n 那么
    
94.         计数值 = 计数值 + 1
    
95.         arr(计数值) = a
    
96.         s = ""
    
97.         循环范围 j = 1 到 n
    
98.             s = s & " " & astr(截取字符串(a ,j ,1))
    
99.         下一句
    
100.         crr(计数值 ,1) = 截取字符串(s ,2)
     
101.         退出 过程
     
102.     结束 如果
     
103.     循环范围 i = 0 到 m
     
104.         如果 包含位置(a ,i) = 0 那么 getall m ,n ,a & i ,arr ,计数值
     
105.     下一句 i
     
106. 结束 过程
     
107. 普通浏览复制代码保存代码打印代码
     
108. 定义变量 为tr 为 变体数据类型 ,crr() 为 字符串
     
109. 过程 宏1()
     
110.     定义变量 arr() 为 字符串 ,brr
     
111.     定义变量 s 为 字符串 ,n 为 整型值 ,i 为 长整型值 ,r 为 长整型值
     
112.     brr = 单元格区域("b2:b" & 单元格区域("b" & 行数 . 计数值) . 结束(方向向上) . 行标)
     
113.     [d:d] . 清除内容
     
114.     循环范围 i = 1 到 数组上限(brr)
     
115.         s = brr(i ,1)
     
116.         n = (字符串长度(s) + 1) / 2
     
117.         r = 应用程序 . permut(n ,n)
     
118.         重定义变量 arr(1 到 r)
     
119.         重定义变量 crr(1 到 r ,1 到 1)
     
120.         astr = 分割字符串(s)
     
121.         getall n - 1 ,n ,"" ,arr ,0
     
122.         单元格区域("d" & 行数 . 计数值) . 结束(方向向上) . 偏移(1) . 重调大小(r) = crr
     
123.     下一句
     
124. 结束 过程
     
125. 过程 getall(传值变量 m 为 整型值 ,传值变量 n 为 整型值 ,传址 a 为 字符串 ,传址 arr() 为 字符串 ,选择 传址 计数值 为 长整型值)
     
126.     定义变量 i 为 长整型值 ,j 为 长整型值 ,s 为 字符串
     
127.     如果 字符串长度(a) = n 那么
     
128.         计数值 = 计数值 + 1
     
129.         arr(计数值) = a
     
130.         s = ""
     
131.         循环范围 j = 1 到 n
     
132.             s = s & " " & astr(截取字符串(a ,j ,1))
     
133.         下一句
     
134.         crr(计数值 ,1) = 截取字符串(s ,2)
     
135.         退出 过程
     
136.     结束 如果
     
137.     循环范围 i = 0 到 m
     
138.         如果 包含位置(a ,i) = 0 那么 getall m ,n ,a & i ,arr ,计数值
     
139.     下一句 i
     
140. 结束 过程
     
141. 
     
142. 
     
143. 
     

复制代码

XUYUJING2007

zhaogang1960 发表于 2012-10-6 01:01
请看附件

For i = 0 To m
第一次循环的时候M就等于2，前面没给M赋值，M为什么会等于2，请教赵老师

CAONI

zhaogang1960 发表于 2012-10-6 00:59
有点难度:

版主你好，我用2003测试了一下，在b列填入6位数字时最多到b92(b2-b92)，当b93填入时就出现：类型不匹配的提示，Range("d" & Rows.count).End(xlUp).Offset(1).Resize(r) = crr显示黄色，也就是说:d列只能填入到d65521而不是65536，我原本想：当d列填写完后就自动换列到从e2开始的e列，依次类推，也就是说b列填入数字其行不受限制，麻烦你修改一下，谢谢！

排序.zip (19.05 KB, 下载次数: 17)

2012-10-6 08:20 上传

点击文件名下载附件

zhaogang1960

CAONI 发表于 2012-10-6 08:20
版主你好，我用2003测试了一下，在b列填入6位数字时最多到b92(b2-b92)，当b93填入时就出现：类型不匹配的 ...

1. Dim aStr As Variant, crr() As String
   
2. 
   
3. 
   
4. Sub 宏1()
   
5.     Dim arr() As String, brr
   
6.     Dim s As String, n As Long, i As Long, r As Long, c As Long
   
7.     Application.ScreenUpdating = False
   
8.     brr = Range("b2:b" & Range("b" & Rows.count).End(xlUp).Row)
   
9.     ActiveSheet.UsedRange.Offset(, 3).ClearContents
   
10.     c = 4
    
11.     For i = 1 To UBound(brr)
    
12.         s = brr(i, 1)
    
13.         n = (Len(s) + 1) / 2
    
14.         r = Application.Permut(n, n)
    
15.         ReDim arr(1 To r)
    
16.         ReDim crr(1 To r, 1 To 1)
    
17.         aStr = Split(s)
    
18.         getall n - 1, n, "", arr, 0
    
19.             lr = Cells(Rows.count, c).End(xlUp).Row
    
20.         If Rows.count - lr < r Then
    
21.             c = c + 1
    
22.             lr = 1
    
23.         End If
    
24.         Cells(lr + 1, c).Resize(r) = crr
    
25.     Next
    
26.     Application.ScreenUpdating = True
    
27. End Sub
    
28. 
    
29. Sub getall(ByVal m As Long, ByVal n As Long, ByRef a As String, ByRef arr() As String, Optional ByRef count As Long)
    
30.     Dim i As Long, j As Long, s As String
    
31.     If Len(a) = n Then
    
32.         count = count + 1
    
33.         arr(count) = a
    
34.         s = ""
    
35.         For j = 1 To n
    
36.             s = s & " " & aStr(Mid(a, j, 1))
    
37.         Next
    
38.         crr(count, 1) = Mid(s, 2)
    
39.         Exit Sub
    
40.     End If
    
41.     For i = 0 To m
    
42.         If InStr(a, i) = 0 Then getall m, n, a & i, arr, count
    
43.     Next i
    
44. 
    
45. End Sub
    

复制代码

zhaogang1960

请看附件
排序.rar (19.37 KB, 下载次数: 53)

2012-10-6 12:19 上传

点击文件名下载附件

zhaogang1960

改进一下，每列填充到最下面一行后，再从下列开始填充：

1. Dim aStr As Variant, crr() As String, mm As Long
   
2. 
   
3. 
   
4. Sub 宏1()
   
5.     Dim arr() As String, drr() As String, brr
   
6.     Dim s As String, n As Long, i As Long, j As Long, r As Long, c As Long, lr As Long
   
7.     Application.ScreenUpdating = False
   
8.     brr = Range("b2:b" & Range("b" & Rows.count).End(xlUp).Row)
   
9.     ActiveSheet.UsedRange.Offset(, 3).ClearContents
   
10.     ReDim drr(1 To Rows.count - 1, 1 To 1)
    
11.     c = 4
    
12.     For i = 1 To UBound(brr)
    
13.         s = brr(i, 1)
    
14.         n = (Len(s) + 1) / 2
    
15.         r = Application.Permut(n, n)
    
16.         ReDim arr(1 To r)
    
17.         ReDim crr(1 To r)
    
18.         aStr = Split(s)
    
19.         getall n - 1, n, "", arr, 0
    
20.         For j = 1 To r
    
21.             If mm = Rows.count - 1 Then
    
22.                 Cells(2, c).Resize(mm) = drr
    
23.                 c = c + 1
    
24.                 mm = 0
    
25.             End If
    
26.             mm = mm + 1
    
27.             drr(mm, 1) = crr(j)
    
28.         Next
    
29.     Next
    
30.     If mm Then Cells(2, c).Resize(mm) = drr
    
31.     mm = 0
    
32.     Erase aStr, crr
    
33.     Application.ScreenUpdating = True
    
34. End Sub
    
35. 
    
36. Sub getall(ByVal m As Long, ByVal n As Long, ByRef a As String, ByRef arr() As String, Optional ByRef count As Long)
    
37.     Dim i As Long, j As Long, s As String
    
38.     If Len(a) = n Then
    
39.         count = count + 1
    
40.         arr(count) = a
    
41.         s = ""
    
42.         For j = 1 To n
    
43.             s = s & " " & aStr(Mid(a, j, 1))
    
44.         Next
    
45.         crr(count) = Mid(s, 2)
    
46.         Exit Sub
    
47.     End If
    
48.     For i = 0 To m
    
49.         If InStr(a, i) = 0 Then getall m, n, a & i, arr, count
    
50.     Next i
    
51. End Sub
    
52. 
    

复制代码

CAONI

zhaogang1960 发表于 2012-10-6 12:19
请看附件

版主你好，你的功力真深厚，这下能很好的运行了，谢谢，谢谢！