[已解决]Excel中用VBA实现三列转四列，请教老师！

lxing20

原始数据：三列				想要的结果：四列
1	2	3		1	2	3	4
聂庆军	饶俊	杜航		聂庆军	饶俊	杜航	陈家林
86	81	87		86	81	87	98
4	5	6		5	6	7	8
陈家林	刘湖	徐文俊		刘湖	徐文俊	卢家辉	刘承辉
98	58	96		58	96	87	93
7	8
卢家辉	刘承辉
87	93

最佳答案

月排行榜 / 总排行榜

fjmxwrs

2013-2-25 22:34

lxing20 发表于 2013-2-25 22:07
谢谢老师及时关注，函数没去试过，因为数据量比较多，还要写入别的工作表，所以想用VBA来解决，能帮我试试 ...

1. Sub test()
   
2.     Dim arr, brr(), x&, i&, j&
   
3.     j = 1
   
4.     arr = Range("B5:D16")
   
5.     ReDim brr(1 To 4, 1 To j + 3)
   
6.     For x = 1 To UBound(arr) Step 4
   
7.         For y = 1 To UBound(arr, 2)
   
8.             If arr(x, y) <> "" Then
   
9.                 i = i + 1
   
10.                 If i > 4 Then
    
11.                     i = 1: j = UBound(brr, 2) + 1
    
12.                     ReDim Preserve brr(1 To 4, 1 To j + 3)
    
13.                 End If
    
14.                 brr(i, j) = arr(x, y)
    
15.                 brr(i, j + 1) = arr(x + 1, y)
    
16.                 brr(i, j + 2) = arr(x + 2, y)
    
17.                 brr(i, j + 3) = arr(x + 3, y)
    
18.             End If
    
19.         Next y
    
20.     Next x
    
21.     Range("L16:O65536").Clear
    
22.     Range("L16").Resize(UBound(brr, 2), 4) = Application.Transpose(brr)
    
23.     Range("L16").Resize(UBound(brr, 2), 4).Borders.LineStyle = 1
    
24. End Sub
    

复制代码

三列转四列用VBA实现.rar (9.65 KB, 下载次数: 7)

2013-2-25 22:34 上传

点击文件名下载附件

跳转到最佳答案楼层

hwc2ycy

用函数的方法楼主会不会？

lxing20

hwc2ycy 发表于 2013-2-25 21:57
用函数的方法楼主会不会？

谢谢老师及时关注，函数没去试过，因为数据量比较多，还要写入别的工作表，所以想用VBA来解决，能帮我试试吗？先谢谢您了！ 急着要用，在线等您。。。。

fjmxwrs

lxing20 发表于 2013-2-25 22:07
谢谢老师及时关注，函数没去试过，因为数据量比较多，还要写入别的工作表，所以想用VBA来解决，能帮我试试 ...

1. Sub test()
   
2.     Dim arr, brr(), x&, i&, j&
   
3.     j = 1
   
4.     arr = Range("B5:D16")
   
5.     ReDim brr(1 To 4, 1 To j + 3)
   
6.     For x = 1 To UBound(arr) Step 4
   
7.         For y = 1 To UBound(arr, 2)
   
8.             If arr(x, y) <> "" Then
   
9.                 i = i + 1
   
10.                 If i > 4 Then
    
11.                     i = 1: j = UBound(brr, 2) + 1
    
12.                     ReDim Preserve brr(1 To 4, 1 To j + 3)
    
13.                 End If
    
14.                 brr(i, j) = arr(x, y)
    
15.                 brr(i, j + 1) = arr(x + 1, y)
    
16.                 brr(i, j + 2) = arr(x + 2, y)
    
17.                 brr(i, j + 3) = arr(x + 3, y)
    
18.             End If
    
19.         Next y
    
20.     Next x
    
21.     Range("L16:O65536").Clear
    
22.     Range("L16").Resize(UBound(brr, 2), 4) = Application.Transpose(brr)
    
23.     Range("L16").Resize(UBound(brr, 2), 4).Borders.LineStyle = 1
    
24. End Sub
    

复制代码

三列转四列用VBA实现.rar (9.65 KB, 下载次数: 7)

2013-2-25 22:34 上传

点击文件名下载附件

lxing20

fjmxwrs 发表于 2013-2-25 22:34

谢谢老师！非常感谢！