用VBA将数据批量行列转换/转置

老貓

原表：

VBA运算后的表：

目的：将原表每一行拆分成31（一个月）行，每行显示一天的产量。
现在能够拆分成31行获取每天的产量，而无法将1-31的日期显示在每一行的日期中，请高手检查命令并赐教，谢谢！

代码如下：

1.     Sub Trans()
   
2.         Dim arr, brr, i&, n&, m As Byte, j As Byte
   
3.         arr = [Sheet1].UsedRange
   
4.         ReDim brr(1 To (UBound(arr, 2) - 4) * (UBound(arr) - 1), 1 To UBound(arr))
   
5.         n = 1
   
6.         For i = 2 To UBound(arr)
   
7.             For m = 1 To 4
   
8.                 brr(n, m) = arr(i, m)
   
9.             Next
   
10.             For j = 5 To UBound(arr, 2)
    
11.                 brr(n, 1) = arr(i, 1)  '1-4列空行填补
    
12.                 brr(n, 2) = arr(i, 2)  '1-4列空行填补
    
13.                 brr(n, 3) = arr(i, 3)  '1-4列空行填补
    
14.                 brr(n, 4) = arr(i, 4)  '1-4列空行填补
    
15.                
    
16.                 brr(n, 5) = arr(i, j)   '第5列列出行项目值
    
17.                 'brr(n, 6) = arr(i, j)  '错误
    
18.                
    
19.                 n = n + 1
    
20.             Next
    
21.         Next
    
22.         With ActiveSheet
    
23.             For m = 1 To 4
    
24.                 .Cells(1, m) = arr(1, m)
    
25.                 .Cells(1, 5) = "当日产量"
    
26.                 .Cells(1, 6) = "日期"
    
27.             Next
    
28.             .[a2].Resize(n - 1, 5) = brr
    
29.         End With
    
30.     End Sub
    

复制代码

A的宏是另一种方法（忽略空产量日期）。

老貓

自己搞定了

1.     Sub Trans()
   
2.         Dim arr, brr, i&, n&, m As Byte, j As Byte
   
3.         arr = [Sheet1].UsedRange
   
4.         ReDim brr(1 To (UBound(arr, 2) - 5) * (UBound(arr) - 1), 1 To UBound(arr))
   
5.         n = 1
   
6.         For i = 2 To UBound(arr)
   
7.             For j = 6 To UBound(arr, 2) '数据转置写入行
   
8.                
   
9.                 For m = 1 To 5  '1-5列数据填补
   
10.                     brr(n, m) = arr(i, m)
    
11.                 Next
    
12.                
    
13.                 brr(n, 6) = arr(i, j)   '第6列列出行项目值
    
14.                 brr(n, 7) = arr(1, j)   '第7列列出行项目值'
    
15.                
    
16.                 n = n + 1
    
17.             Next
    
18.         Next
    
19.         With ActiveSheet
    
20.             For m = 1 To 5
    
21.                 .Cells(1, m) = arr(1, m)
    
22.                 .Cells(1, 6) = "当日产量"
    
23.                 .Cells(1, 7) = "日期"
    
24.             Next
    
25.             .[a2].Resize(n - 1, 7) = brr    '显示列数
    
26.         End With
    
27.     End Sub
    

复制代码

deadzlq

PQ参考解法（逆透视）