[已解决]竖列数据转换成横列数据

蓝天一片云

如何将A1:B21区域中的数据转换成E1:L15区域的数据
相同数据在一起放置5行,超过5行的数据增加列数放置,效果见附件.请高手相助.谢谢!

最佳答案

月排行榜 / 总排行榜

hrpotter

2012-5-27 09:45

蓝天一片云 发表于 2012-5-26 22:26
谢谢您的回复！
如果能将最后的单元格赋值改成数组赋值，效果就更好了。

原理是一样的，把单元格区域替换成数组就行了

1. Sub test()
   
2.     Dim ar, br, cr, dr(1 To 1000, 1 To 240), d
   
3.     Dim i As Integer, j As Integer, k As Integer
   
4.     Range("e:iv").Clear
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     ar = Range("a1:b1")
   
7.     br = Range("a2:b" & Range("a65536").End(xlUp).Row)
   
8.     For i = 1 To UBound(br)
   
9.         d(br(i, 1)) = ""
   
10.     Next
    
11.     cr = d.keys
    
12.     For i = 0 To UBound(cr)
    
13.         k = 0
    
14.         For j = 1 To UBound(br)
    
15.             If br(j, 1) = cr(i) Then
    
16.                 If (k Mod 4) = 0 Then
    
17.                     dr(5 * i + 1, (k \ 4) * 3 + 1) = ar(1, 1)
    
18.                     dr(5 * i + 1, (k \ 4) * 3 + 2) = ar(1, 2)
    
19.                 End If
    
20.                 dr(5 * i + 2 + (k Mod 4), (k \ 4) * 3 + 1) = br(j, 1)
    
21.                 dr(5 * i + 2 + (k Mod 4), (k \ 4) * 3 + 2) = br(j, 2)
    
22.                 k = k + 1
    
23.             End If
    
24.         Next
    
25.     Next
    
26.     Range("e1").Resize(1000, 240) = dr
    
27. End Sub

复制代码

跳转到最佳答案楼层

无聊的疯子

搞不明白为啥要这样排??

蓝天一片云

无聊的疯子 发表于 2012-5-26 21:02
搞不明白为啥要这样排??

想学习字典排列的方法，请师兄指点。谢谢！

hrpotter

蓝天一片云 发表于 2012-5-26 21:12
想学习字典排列的方法，请师兄指点。谢谢！

1. Sub test()
   
2.     Dim ar, br, cr, d
   
3.     Dim i As Integer, j As Integer, k As Integer
   
4.     Range("e:iv").Clear
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     ar = Range("a1:b1")
   
7.     br = Range("a2:b" & Range("a65536").End(xlUp).Row)
   
8.     For i = 1 To UBound(br)
   
9.         d(br(i, 1)) = br(i, 1)
   
10.     Next
    
11.     cr = d.items
    
12.     For i = 0 To UBound(cr)
    
13.         k = 0
    
14.         For j = 1 To UBound(br)
    
15.             If br(j, 1) = cr(i) Then
    
16.                 If (k Mod 4) = 0 Then
    
17.                     Cells(5 * i + 1, (k \ 4) * 3 + 5).Resize(1, 2) = ar
    
18.                 End If
    
19.                 Cells(5 * i + 2 + (k Mod 4), (k \ 4) * 3 + 5) = br(j, 1)
    
20.                 Cells(5 * i + 2 + (k Mod 4), (k \ 4) * 3 + 6) = br(j, 2)
    
21.                 k = k + 1
    
22.             End If
    
23.         Next
    
24.     Next
    
25. End Sub

复制代码

蓝天一片云

hrpotter 发表于 2012-5-26 22:04

谢谢您的回复！
如果能将最后的单元格赋值改成数组赋值，效果就更好了。

hrpotter

蓝天一片云 发表于 2012-5-26 22:26
谢谢您的回复！
如果能将最后的单元格赋值改成数组赋值，效果就更好了。

原理是一样的，把单元格区域替换成数组就行了

1. Sub test()
   
2.     Dim ar, br, cr, dr(1 To 1000, 1 To 240), d
   
3.     Dim i As Integer, j As Integer, k As Integer
   
4.     Range("e:iv").Clear
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     ar = Range("a1:b1")
   
7.     br = Range("a2:b" & Range("a65536").End(xlUp).Row)
   
8.     For i = 1 To UBound(br)
   
9.         d(br(i, 1)) = ""
   
10.     Next
    
11.     cr = d.keys
    
12.     For i = 0 To UBound(cr)
    
13.         k = 0
    
14.         For j = 1 To UBound(br)
    
15.             If br(j, 1) = cr(i) Then
    
16.                 If (k Mod 4) = 0 Then
    
17.                     dr(5 * i + 1, (k \ 4) * 3 + 1) = ar(1, 1)
    
18.                     dr(5 * i + 1, (k \ 4) * 3 + 2) = ar(1, 2)
    
19.                 End If
    
20.                 dr(5 * i + 2 + (k Mod 4), (k \ 4) * 3 + 1) = br(j, 1)
    
21.                 dr(5 * i + 2 + (k Mod 4), (k \ 4) * 3 + 2) = br(j, 2)
    
22.                 k = k + 1
    
23.             End If
    
24.         Next
    
25.     Next
    
26.     Range("e1").Resize(1000, 240) = dr
    
27. End Sub

复制代码