需把一张表的数据吗，按另一张的格式打印出来，求指导，谢谢

lianglin

需把一张表的数据吗，按另一张的格式打印出来，求指导，谢谢。
试了一下录制宏，总是黏贴不对，大概是行列转置没法解决。用vba又不熟，求大神指导一下
下面是表格。
表格打印.zip (21.77 KB, 下载次数: 1)

2018-7-12 16:53 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   With Worksheets("成绩统计表")
   
5.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.     arr = .Range("a4:j" & r)
   
7.   End With
   
8.   ReDim brr(1 To UBound(arr) * 6, 1 To 6)
   
9.   m = 0
   
10.   For i = 2 To UBound(arr)
    
11.     m = m + 1
    
12.     brr(m, 1) = "2018.5.7-5.11"
    
13.     brr(m, 2) = "理论"
    
14.     brr(m, 3) = 40
    
15.     brr(m, 4) = "脱产"
    
16.     brr(m, 5) = arr(i, 5)
    
17.     brr(m, 6) = arr(i, 2)
    
18.     For j = 6 To UBound(arr, 2)
    
19.       m = m + 1
    
20.       brr(m, 2) = arr(1, j)
    
21.       brr(m, 5) = arr(i, j)
    
22.     Next
    
23.   Next
    
24.   With Worksheets("打印")
    
25.     .Cells.Clear
    
26.     .Range("a1").Resize(m, UBound(brr, 2)) = brr
    
27.     For i = 1 To m Step 6
    
28.       For Each y In Array(1, 3, 4, 6)
    
29.         .Cells(i, y).Resize(6, 1).Merge
    
30.       Next
    
31.     Next
    
32.     .Range("a1:f" & m).Borders.LineStyle = xlContinuous
    
33.     With .UsedRange
    
34.       .HorizontalAlignment = xlCenter
    
35.       .VerticalAlignment = xlCenter
    
36.     End With
    
37.   End With
    
38. End Sub
    

复制代码

chxw68

详见附件。

lianglin

非常感谢chxw68的回复，试了一下，完全解决了问题。并且在后面插入更多的数据也能自动增加。真是高人啊，再次感谢！