[已解决]老师们，用VBA能实现吗？

vba新手2

列转行，不知道这样格式能不能实现，求老师帮忙

最佳答案

月排行榜 / 总排行榜

雪舞子

2016-9-4 15:58

vba可以做到，但有些麻烦，
不知这样做有何意义。

转换成第二种格式代码如下：

1. Sub test_XWZ()
   
2.     Dim arr, brr(), i%, j%, n%, m%
   
3.     arr = Range("p5").CurrentRegion
   
4.     ReDim brr(1 To 4, 1 To 2 * (UBound(arr) - 4))
   
5.     For i = 1 To 3
   
6.         m = 1
   
7.         n = i - 2 * (i = 3)
   
8.         For j = 5 To UBound(arr)
   
9.             brr(i, m) = arr(j, n)
   
10.             brr(i, m + 1) = arr(j, n)
    
11.             m = m + 2
    
12.         Next
    
13.     Next
    
14.     m = 1
    
15.     For j = 5 To UBound(arr)
    
16.         brr(4, m) = arr(j, 3)
    
17.         brr(4, m + 1) = arr(j, 4)
    
18.         m = m + 2
    
19.     Next
    
20.     [w23:zz26] = ""
    
21.     [w23].Resize(4, m - 1) = brr
    
22.     Application.DisplayAlerts = False
    
23.     For i = 1 To 3
    
24.         For j = 1 To m - 1 Step 2
    
25.             Range(Cells(22 + i, 22 + j), Cells(22 + i, 23 + j)).Merge
    
26.         Next
    
27.     Next
    
28.     With [w23].CurrentRegion
    
29.         .HorizontalAlignment = xlCenter
    
30.         .Font.Size = 9
    
31.         .Columns.AutoFit
    
32.         .Borders.LineStyle = 1
    
33.     End With
    
34.     Application.DisplayAlerts = True
    
35. End Sub

复制代码

Boox1.rar (23.6 KB, 下载次数: 11)

2016-9-4 15:58 上传

点击文件名下载附件

跳转到最佳答案楼层

雪舞子

vba可以做到，但有些麻烦，
不知这样做有何意义。

转换成第二种格式代码如下：

1. Sub test_XWZ()
   
2.     Dim arr, brr(), i%, j%, n%, m%
   
3.     arr = Range("p5").CurrentRegion
   
4.     ReDim brr(1 To 4, 1 To 2 * (UBound(arr) - 4))
   
5.     For i = 1 To 3
   
6.         m = 1
   
7.         n = i - 2 * (i = 3)
   
8.         For j = 5 To UBound(arr)
   
9.             brr(i, m) = arr(j, n)
   
10.             brr(i, m + 1) = arr(j, n)
    
11.             m = m + 2
    
12.         Next
    
13.     Next
    
14.     m = 1
    
15.     For j = 5 To UBound(arr)
    
16.         brr(4, m) = arr(j, 3)
    
17.         brr(4, m + 1) = arr(j, 4)
    
18.         m = m + 2
    
19.     Next
    
20.     [w23:zz26] = ""
    
21.     [w23].Resize(4, m - 1) = brr
    
22.     Application.DisplayAlerts = False
    
23.     For i = 1 To 3
    
24.         For j = 1 To m - 1 Step 2
    
25.             Range(Cells(22 + i, 22 + j), Cells(22 + i, 23 + j)).Merge
    
26.         Next
    
27.     Next
    
28.     With [w23].CurrentRegion
    
29.         .HorizontalAlignment = xlCenter
    
30.         .Font.Size = 9
    
31.         .Columns.AutoFit
    
32.         .Borders.LineStyle = 1
    
33.     End With
    
34.     Application.DisplayAlerts = True
    
35. End Sub

复制代码

Boox1.rar (23.6 KB, 下载次数: 11)

2016-9-4 15:58 上传

点击文件名下载附件

vba新手2

雪舞子 发表于 2016-9-4 15:58
vba可以做到，但有些麻烦，
不知这样做有何意义。

谢谢老师；解决问题。