几个例子-有关行列转置（收集归纳自用）

creatorzxz

谢谢分享,收藏备用

HUA79100101

[分享] 几个例子-有关行列转置（收集归纳自用）

autumnalRain

autumnalRain 发表于 2015-12-4 09:29
第二个：代码出自zhong1218老师 。POWER QUERY也可实现。brr行数可以计算出……
...

复杂一些的交叉数据格式转换

1. Sub Transform()
   
2.     Dim brr(1 To 1000, 1 To 4)
   
3.     brr(1, 1) = "姓名": brr(1, 2) = "款号": brr(1, 3) = "序号": brr(1, 4) = "产量"
   
4.     arr = Sheets("源数据").Range("a1").CurrentRegion
   
5.     For i = 3 To UBound(arr, 2) '列
   
6.         For j = 2 To UBound(arr, 1) '行
   
7.                 n = n + 1
   
8.                 brr(n + 1, 1) = arr(j, 1)
   
9.                 brr(n + 1, 2) = arr(j, 2)
   
10.                 brr(n + 1, 3) = arr(1, i)
    
11.                 brr(n + 1, 4) = arr(j, i)
    
12.         Next j
    
13.     Next i
    
14.     Sheets("转置后").Cells.ClearContents
    
15.     Sheets("转置后").Range("a1").Resize(UBound(brr), 4) = brr
    
16.     Call DataSort
    
17. End Sub
    
18. Sub DataSort()
    
19.     Rmax = Sheets("转置后").[a1048576].End(3).Row
    
20.     Sheets("转置后").Sort.SortFields.Clear
    
21.     Sheets("转置后").Sort.SortFields.Add2 Key:=Range("A2:A" & Rmax), _
    
22.         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
23.     Sheets("转置后").Sort.SortFields.Add2 Key:=Range("B2:B" & Rmax), _
    
24.         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
25.     Sheets("转置后").Sort.SortFields.Add2 Key:=Range("C2:C" & Rmax), _
    
26.         SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
27.     With Sheets("转置后").Sort
    
28.         .SetRange Range("A1:D" & Rmax)
    
29.         .Header = xlYes
    
30.         .MatchCase = False
    
31.         .Orientation = xlTopToBottom
    
32.         .SortMethod = xlPinYin
    
33.         .Apply
    
34.     End With
    
35. End Sub

复制代码

autumnalRain

1. Sub Transform2()
   
2.     Dim brr(1 To 1000, 1 To 4)
   
3.     brr(1, 1) = "姓名": brr(1, 2) = "款号": brr(1, 3) = "序号": brr(1, 4) = "产量"
   
4.     arr = Sheets("源数据").Range("a1").CurrentRegion
   
5.         For j = 2 To UBound(arr, 1) '行
   
6.             For i = 3 To UBound(arr, 2) '列
   
7.                 n = n + 1
   
8.                 brr(n + 1, 1) = arr(j, 1)
   
9.                 brr(n + 1, 2) = arr(j, 2)
   
10.                 brr(n + 1, 3) = arr(1, i)
    
11.                 brr(n + 1, 4) = arr(j, i)
    
12.             Next i
    
13.         Next j
    
14.     Sheets("转置后").Cells.ClearContents
    
15.     Sheets("转置后").Range("a1").Resize(UBound(brr), 4) = brr
    
16.    End Sub
    

复制代码

autumnalRain 发表于 2019-4-8 18:27
复杂一些的交叉数据格式转换

第一次逻辑不太清晰。不用排序，而且排序结果不一定符合要求。行列循环次序变下就可以实现。增加一列，见转换格式2

1. Sub Transform2()
   
2.     Dim brr(1 To 1000, 1 To 5)
   
3.     brr(1, 1) = "姓名": brr(1, 2) = "款式": brr(1, 3) = "款号": brr(1, 4) = "序号": brr(1, 5) = "产量"
   
4.     arr = Sheets("源数据").Range("a1").CurrentRegion
   
5.         For j = 2 To UBound(arr, 1) '行
   
6.             For i = 4 To UBound(arr, 2) '列
   
7.                 n = n + 1
   
8.                 brr(n + 1, 1) = arr(j, 1)
   
9.                 brr(n + 1, 2) = arr(j, 2)
   
10.                 brr(n + 1, 3) = arr(j, 3)
    
11.                 brr(n + 1, 4) = arr(1, i)
    
12.                 brr(n + 1, 5) = arr(j, i)
    
13.             Next i
    
14.         Next j
    
15.     Sheets("转置后").Cells.ClearContents
    
16.     Sheets("转置后").Range("a1").Resize(UBound(brr), 5) = brr
    
17. End Sub

复制代码

blackttea1

谢谢分享,收藏备用

无声地拥抱

不错的值得收藏的

yangkai_lin

收藏！！！！

thzss

收集很完整，各种转置基本都有了

newlove

服了，学习了！

xvjiex

感谢楼主分享行列转置（收集归纳自用）