[已解决]如何将A列文字变成C列文字

蓝天一片云

将A列文字变成C列文字
变化规则
1.6个文字为一组将A列文字重新排列,第7个文字和第1个文字相同,第8个文字和第2个文字相同,第9个文字和第3个文字相同,以此类推.有相同的文字时必须对应上一组文字.(不够6个时插入空行,输入数字1)
2.没有相同文字时可随意排列.

最佳答案

月排行榜 / 总排行榜

liuguansky

2012-5-12 21:42

1. 
   
2. Sub justT()
   
3.     Dim D As New Dictionary, Arr, I&, K&, j As Byte
   
4.     Dim Ar(1 To 60000, 1 To 1), Ar1, Ar2, M&, N&
   
5.     Arr = Range([a1], [a1].End(4)).Value
   
6.     For I = 1 To UBound(Arr)
   
7.         D(Arr(I, 1)) = D(Arr(I, 1)) + 1
   
8. Sub justT()
   
9.     Dim D As New Dictionary, Arr, I&, K&, j As Byte
   
10.     Dim Ar(1 To 60000, 1 To 1), Ar1, Ar2, M&, N&, U As Byte
    
11.     Arr = Range([a1], [a1].End(4)).Value
    
12.     For I = 1 To UBound(Arr)
    
13.         D(Arr(I, 1)) = D(Arr(I, 1)) + 1
    
14.     Next I
    
15.     Ar1 = D.Keys: Ar2 = D.Items
    
16.     For I = 0 To UBound(Ar1) Step 6
    
17.         M = 0
    
18.         If UBound(Ar1) - I < 5 Then
    
19.             U = (UBound(Ar1) + 1) Mod 6
    
20.         Else
    
21.             U = 6
    
22.         End If
    
23.         For j = 0 To U - 1
    
24.             If Ar2(I + j) > M Then M = Ar2(I + j)
    
25.         Next j
    
26.         For N = 1 To M
    
27.             For j = 0 To U - 1
    
28.                 K = K + 1
    
29.                 If Ar2(I + j) < N Then
    
30.                     Ar(K, 1) = 1
    
31.                 Else
    
32.                     Ar(K, 1) = Ar1(I + j)
    
33.                 End If
    
34.         Next j, N
    
35.     Next I
    
36.     Range([b1], [b1].End(4)).ClearContents
    
37.     [b1].Resize(K, 1) = Ar
    
38.     Set D = Nothing
    
39.     MsgBox "&acute;&brvbar;&Agrave;í&Iacute;ê±&Iuml;&pound;&not;&Ccedil;&euml;&ordm;&Euml;&Ecirc;&micro;&pound;&iexcl;"
    
40. End Sub
    

复制代码

在B列生成的结果，请看附件是否与你的要求相符。如果最后不足六个，只循环不足部分，不会以1进行填充。
数据排列512.rar (10.73 KB, 下载次数: 58)

2012-5-12 21:42 上传

点击文件名下载附件

跳转到最佳答案楼层

蓝天一片云

请高手出手相助。谢谢！

那么的帅

蓝天一片云 发表于 2012-5-11 14:25
请高手出手相助。谢谢！

看不懂啥意思

liuguansky

1. 
   
2. Sub justT()
   
3.     Dim D As New Dictionary, Arr, I&, K&, j As Byte
   
4.     Dim Ar(1 To 60000, 1 To 1), Ar1, Ar2, M&, N&
   
5.     Arr = Range([a1], [a1].End(4)).Value
   
6.     For I = 1 To UBound(Arr)
   
7.         D(Arr(I, 1)) = D(Arr(I, 1)) + 1
   
8. Sub justT()
   
9.     Dim D As New Dictionary, Arr, I&, K&, j As Byte
   
10.     Dim Ar(1 To 60000, 1 To 1), Ar1, Ar2, M&, N&, U As Byte
    
11.     Arr = Range([a1], [a1].End(4)).Value
    
12.     For I = 1 To UBound(Arr)
    
13.         D(Arr(I, 1)) = D(Arr(I, 1)) + 1
    
14.     Next I
    
15.     Ar1 = D.Keys: Ar2 = D.Items
    
16.     For I = 0 To UBound(Ar1) Step 6
    
17.         M = 0
    
18.         If UBound(Ar1) - I < 5 Then
    
19.             U = (UBound(Ar1) + 1) Mod 6
    
20.         Else
    
21.             U = 6
    
22.         End If
    
23.         For j = 0 To U - 1
    
24.             If Ar2(I + j) > M Then M = Ar2(I + j)
    
25.         Next j
    
26.         For N = 1 To M
    
27.             For j = 0 To U - 1
    
28.                 K = K + 1
    
29.                 If Ar2(I + j) < N Then
    
30.                     Ar(K, 1) = 1
    
31.                 Else
    
32.                     Ar(K, 1) = Ar1(I + j)
    
33.                 End If
    
34.         Next j, N
    
35.     Next I
    
36.     Range([b1], [b1].End(4)).ClearContents
    
37.     [b1].Resize(K, 1) = Ar
    
38.     Set D = Nothing
    
39.     MsgBox "&acute;&brvbar;&Agrave;í&Iacute;ê±&Iuml;&pound;&not;&Ccedil;&euml;&ordm;&Euml;&Ecirc;&micro;&pound;&iexcl;"
    
40. End Sub
    

复制代码

在B列生成的结果，请看附件是否与你的要求相符。如果最后不足六个，只循环不足部分，不会以1进行填充。
数据排列512.rar (10.73 KB, 下载次数: 58)

2012-5-12 21:42 上传

点击文件名下载附件

蓝天一片云

liuguansky 发表于 2012-5-12 21:42
在B列生成的结果，请看附件是否与你的要求相符。如果最后不足六个，只循环不足部分，不会以1进行填充。
...

字典加数组运行的非常快。版主的功力就是不一样。厉害啊！
如果有多列数据时其它列数据如何根据A列数据变化？如何修改代码？谢谢！

liuguansky

数据排列5122.rar (14.92 KB, 下载次数: 20)

2012-6-13 13:09 上传

点击文件名下载附件

1. Sub justT()
   
2.     Dim D As New Dictionary, Arr, I&, K&, j As Byte, O As Byte
   
3.     Dim Ar(1 To 60000, 1 To 4), Ar1, Ar2, M&, N&, U As Byte, Ak
   
4.     Arr = Range([A1], [d1].End(4)).Value
   
5.     For I = 1 To UBound(Arr)
   
6.         If D.Exists(Arr(I, 1)) Then
   
7.             Ar1 = D(Arr(I, 1))
   
8.             Ar1(0) = Ar1(0) + 1
   
9.             Ar1(1) = Ar1(1) & "," & I
   
10.             D(Arr(I, 1)) = Ar1
    
11.         Else
    
12.             D.Add Arr(I, 1), Array(1, I)
    
13.         End If
    
14.     Next I
    
15.     Ar1 = D.Keys: Ar2 = D.Items
    
16.     For I = 0 To UBound(Ar1) Step 6
    
17.         M = 0
    
18.         If UBound(Ar1) - I < 5 Then
    
19.             U = (UBound(Ar1) + 1) Mod 6
    
20.         Else
    
21.             U = 6
    
22.         End If
    
23.         For j = 0 To U - 1
    
24.             If Ar2(I + j)(0) > M Then M = Ar2(I + j)(0)
    
25.         Next j
    
26.         For N = 1 To M
    
27.             For j = 0 To U - 1
    
28.                 K = K + 1
    
29.                 If Ar2(I + j)(0) < N Then
    
30.                     Ar(K, 1) = 1
    
31.                 Else
    
32.                     Ak = Split(Ar2(I + j)(1), ",")
    
33.                     For O = 1 To 4
    
34.                         Ar(K, O) = Arr(Ak(0) + 0, O)
    
35.                     Next O
    
36.                     Ar2(I + j) = Array(Ar2(I + j)(0), Mid(Replace(Ar2(I + j)(1), Ak(0), ""), 2))
    
37.                 End If
    
38.         Next j, N
    
39.     Next I
    
40.     Range([G1], [j1].End(4)).ClearContents
    
41.     [G1].Resize(K, 4) = Ar
    
42.     Set D = Nothing
    
43.     MsgBox "&acute;&brvbar;&Agrave;í&Iacute;ê±&Iuml;&pound;&not;&Ccedil;&euml;&ordm;&Euml;&Ecirc;&micro;&pound;&iexcl;"
    
44. End Sub

复制代码

试试，是这样的意思吗？

蓝天一片云

liuguansky 发表于 2012-6-13 13:09
试试，是这样的意思吗？

对。就是这种效果。谢谢版主老师！
这思路非常好！代码难度相当大。看了后也只是理解一点，完全理解可能需要一段时间。