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

autumnalRain

第八个例子与第一个例子相比：

1、相同之处：都是将多行数据合并为一行；

2、不同之处是，第一个例子多行数据时列数固定，第八个例子则不固定

autumnalRain

第八个例子与第七个例子相比：

1、相同处：都是多行数据合并为单行数据

2、不同处：第八个例子列数不固定，第七个列数固定

autumnalRain

第九个例子：By 'zax010

1. Sub zz()
   
2.     Dim d1, d2, ar
   
3.     Set d1 = CreateObject("Scripting.Dictionary")
   
4.     Set d2 = CreateObject("Scripting.Dictionary")
   
5.     ar = [a1].CurrentRegion
   
6.     For i = 3 To UBound(ar)
   
7.         d1(ar(i, 1) & "-" & ar(i, 2)) = d1(ar(i, 1) & "-" & ar(i, 2)) & "," & ar(i, 3) & "," & ar(i, 4) & "," & ar(i, 5) & "," & ar(i, 6)
   
8.         d2(ar(i, 1) & "-" & ar(i, 2)) = d2(ar(i, 1) & "-" & ar(i, 2)) + ar(i, 4)
   
9.     Next
   
10.     For Each k In d1.keys
    
11.         Cells(17 + n, 1).Resize(1, 2) = Split(k, "-")
    
12.         Cells(17 + n, 3) = d2(k)
    
13.         s = Split(Mid(d1(k), 2), ",")
    
14.         Cells(17 + n, 4).Resize(1, UBound(s) + 1) = s
    
15.         n = n + 1
    
16.     Next
    
17. End Sub

复制代码

autumnalRain

第十个例子：将A列数据整理成CD列格式

1. Sub zhengli()
   
2. irow = [a1].End(xlDown).Row
   
3. For i = irow To 1 Step -1
   
4.     If Application.IsText(Cells(i, 1)) Then
   
5.             sr = sr & "," & Cells(i, 1)
   
6.         Else
   
7.             Cells(i, 2) = Right(sr, Len(sr) - 1)
   
8.             sr = ""
   
9.     End If
   
10. Next
    
11. Columns(1).SpecialCells(xlCellTypeConstants, xlContents).Delete
    
12. Columns(2).SpecialCells(xlCellTypeBlanks).Delete
    
13. End Sub

复制代码

autumnalRain

第十一个例子：一列转多列，注意一维数组和二维数组循环起始值

1. Sub classic()
   
2.     x = 8
   
3.     s = Split(Join(Application.Transpose(Range([A1], [A1].End(xlDown))), "|"), "|")
   
4.     y = UBound(s)
   
5.     For i = LBound(s) To UBound(s)
   
6.         Cells(Int(i / 8) + 1, (i Mod 8) + 3) = s(i)
   
7.     Next
   
8. End Sub

复制代码

1. Sub TEST()
   
2.     x = 8
   
3.     ARR = Range([A1], [A1].End(xlDown))
   
4.     A = UBound(ARR)
   
5.     For i = 0 To A - 1
   
6.         Cells(Int(i / 8) + 1, (i Mod 8) + 3) = ARR(i + 1, 1)
   
7.     Next
   
8. End Sub

复制代码

autumnalRain

纯数组方法

1. Sub classic()
   
2.     Dim arr(), x, s, y, i
   
3.     x = 8
   
4.     ReDim arr(0 To 10000, 1 To x)
   
5.     s = Split(Join(Application.Transpose(Range([A1], [A1].End(xlDown))), "|"), "|")
   
6.     y = UBound(s)
   
7.     For i = LBound(s) To UBound(s)
   
8.         arr(Int(i / 8) + 1, (i Mod 8) + 1) = s(i)
   
9.     Next
   
10.     [c10].Resize(10001, 8) = arr
    
11. End Sub

复制代码

autumnalRain

更通用的写法儿

1. Sub classic()
   
2.     Dim arr(), ColumnNum, s, y, i, LineNum
   
3.     ColumnNum = 13
   
4.     s = Split(Join(Application.Transpose(Range([A1], [A1].End(xlDown))), "|"), "|")
   
5.     y = UBound(s) + 1
   
6.     LineNum = Application.RoundUp(y / ColumnNum, 0)
   
7.     ReDim arr(0 To LineNum, 1 To ColumnNum)
   
8.     For i = LBound(s) To UBound(s)
   
9.         arr(i \ ColumnNum, (i Mod ColumnNum) + 1) = s(i)
   
10.     Next
    
11.     [c10].Resize(LineNum + 1, ColumnNum) = arr
    
12. End Sub

复制代码

autumnalRain

函数

1. Function TRANSPOSEDATA(MyRange As RANGE, ColumnNum As Integer)
   
2.     Dim arr(), s, y, i, LineNum
   
3.     s = Split(Join(Application.Transpose(MyRange), "|"), "|")
   
4.     y = UBound(s) + 1
   
5.     LineNum = Application.RoundUp(y / ColumnNum, 0)
   
6.     ReDim arr(0 To LineNum, 1 To ColumnNum)
   
7.     For i = LBound(s) To UBound(s)
   
8.         arr(i \ ColumnNum, (i Mod ColumnNum) + 1) = s(i)
   
9.     Next
   
10.     TRANSPOSEDATA = arr
    
11. End Function
    

复制代码

autumnalRain

第十二个例子：

1. Sub test()
   
2.     Ir = Cells(Rows.Count, "k").End(xlUp).Row
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For i = 2 To Ir
   
5.         d(Cells(i, "K").Value) = d(Cells(i, "K").Value) & Cells(i, "I").Value & Cells(i, "J").Value
   
6.     Next
   
7. m = d.Count
   
8. For j = 0 To m - 1
   
9.     Cells((j + 1) * 2, "A") = d.keys()(j)
   
10.     Cells((j + 1) * 2 + 1, "A") = d.items()(j)
    
11. Next
    
12. End Sub

复制代码

autumnalRain

第十三个例子：

1. Sub TEST()
   
2. arr = [B3:H8]
   
3. Dim brr(1 To 100, 1 To 4)
   
4. For i = 1 To 6
   
5.     For j = 3 To 7
   
6. 
   
7.             If arr(i, j) <> "" Then
   
8.                   k = k + 1
   
9.                   brr(k, 1) = k
   
10.                   brr(k, 2) = arr(i, 1)
    
11.                   brr(k, 3) = arr(i, j)
    
12.                   brr(k, 4) = arr(i, 2)
    
13.             End If
    
14. 
    
15.      Next j
    
16. Next i
    
17. [P3].Resize(UBound(brr), UBound(brr, 2)) = brr
    
18. End Sub

复制代码