[已解决]Sheet0的数据排列成Sheet1的形式

xiaovba

Sheet0是原文件，用宏的方法排列成Sheet1的形式。
在这里先谢谢了！
例文.rar (11.96 KB, 下载次数: 5)

2017-3-4 22:18 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

雪舞子

2017-3-5 06:38

1. Sub test()
   
2.     Dim arr, ar, brr(), i&, j&
   
3.     ar = Array(1, 2, 3, 4, 5, 11, 12, 13, 18, 19, 20, 21, 22)
   
4.     arr = Sheets("Sheet0").Range("a1").CurrentRegion
   
5.     ReDim brr(1 To 2 * UBound(arr), 12)
   
6.     For i = 1 To UBound(arr)
   
7.         For j = 0 To UBound(ar)
   
8.             If i > 1 Then
   
9.                 brr((i - 1) * 2, j) = arr(i, ar(j))
   
10.             Else
    
11.                 brr(i, j) = arr(i, ar(j))
    
12.             End If
    
13.         Next
    
14.     Next
    
15.     With Sheets("Sheet1")
    
16.         .Cells.Clear
    
17.         With .Range("a1").Resize(UBound(brr) - 1, 13)
    
18.             .Value = brr
    
19.             .Borders.LineStyle = 1
    
20.         End With
    
21.     End With
    
22. End Sub
    

复制代码

例文.rar (25.59 KB, 下载次数: 4)

2017-3-5 06:38 上传

点击文件名下载附件

跳转到最佳答案楼层

雪舞子

1. Sub test()
   
2.     Dim arr, ar, brr(), i&, j&
   
3.     ar = Array(1, 2, 3, 4, 5, 11, 12, 13, 18, 19, 20, 21, 22)
   
4.     arr = Sheets("Sheet0").Range("a1").CurrentRegion
   
5.     ReDim brr(1 To 2 * UBound(arr), 12)
   
6.     For i = 1 To UBound(arr)
   
7.         For j = 0 To UBound(ar)
   
8.             If i > 1 Then
   
9.                 brr((i - 1) * 2, j) = arr(i, ar(j))
   
10.             Else
    
11.                 brr(i, j) = arr(i, ar(j))
    
12.             End If
    
13.         Next
    
14.     Next
    
15.     With Sheets("Sheet1")
    
16.         .Cells.Clear
    
17.         With .Range("a1").Resize(UBound(brr) - 1, 13)
    
18.             .Value = brr
    
19.             .Borders.LineStyle = 1
    
20.         End With
    
21.     End With
    
22. End Sub
    

复制代码

例文.rar (25.59 KB, 下载次数: 4)

2017-3-5 06:38 上传

点击文件名下载附件

xiaovba

雪舞子 发表于 2017-3-5 06:38

谢谢你，还有个小问题，就是我按照图片里设置好后，一点按钮，字号12和垂直对齐以及缩小字体填充都变了。是什么原因，帮忙解答一下，谢谢！

雪舞子

xiaovba 发表于 2017-3-5 10:16
谢谢你，还有个小问题，就是我按照图片里设置好后，一点按钮，字号12和垂直对齐以及缩小字体填充都变了。 ...

1. Sub test()
   
2.     Dim arr, ar, brr(), i&, j&
   
3.     ar = Array(1, 2, 3, 4, 5, 11, 12, 13, 18, 19, 20, 21, 22)
   
4.     arr = Sheets("Sheet0").Range("a1").CurrentRegion
   
5.     ReDim brr(1 To 2 * UBound(arr), 12)
   
6.     For i = 1 To UBound(arr)
   
7.         For j = 0 To UBound(ar)
   
8.             If i > 1 Then
   
9.                 brr((i - 1) * 2, j) = arr(i, ar(j))
   
10.             Else
    
11.                 brr(i, j) = arr(i, ar(j))
    
12.             End If
    
13.         Next
    
14.     Next
    
15.     With Sheets("Sheet1")
    
16.         .Cells.Borders.LineStyle = 0
    
17.         .Cells.ClearContents
    
18.         With .Range("a1").Resize(UBound(brr) - 1, 13)
    
19.             .Value = brr
    
20.             .Borders.LineStyle = 1
    
21.         End With
    
22.     End With
    
23. End Sub

复制代码

例文.rar (26.18 KB, 下载次数: 4)

2017-3-5 10:35 上传

点击文件名下载附件

xiaovba

雪舞子 发表于 2017-3-5 10:35

谢谢