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

autumnalRain

20楼Yaong_3老师的构思很巧妙，一个变量把行列以及数组的元素位置全部联系在一起了

autumnalRain

第六个例子:特殊转置，要求上下左右数据互换

1. Sub test()
   
2. Dim brr(), arr
   
3. ir = Cells(Rows.Count, 2).End(xlUp).Row
   
4. ReDim brr(1 To ir, 1 To 6)
   
5. For i = ir To 2 Step -1
   
6.     arr = Range(Cells(i, 1), Cells(i, "xfd").End(xlToLeft))
   
7.     y = UBound(arr, 2)
   
8.     x = LBound(arr, 2)
   
9.     For j = y To x + 1 Step -1
   
10.          brr(ir - i + 1, y - j + 1) = arr(1, j)
    
11.     Next j
    
12. Next i
    
13. Cells(1, 10).Resize(1, 6) = [a1:f1].Value
    
14. Cells(2, 11).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    
15. Do While Cells(m + 2, 11) <> ""
    
16.    Cells(m + 2, 10) = m + 1
    
17.    m = m + 1
    
18. Loop
    
19. End Sub

复制代码

autumnalRain

此例子需要说明的地方是：如果使用了END方法，则需要将数据表以外的其他所有数据清空，否则会报错

autumnalRain

1. 自动编号时还可以再优化下，见第12行

复制代码

1. Sub test()
   
2. Dim brr(), arr
   
3. ir = Cells(Rows.Count, 2).End(xlUp).Row
   
4. ReDim brr(1 To ir, 1 To 6)
   
5. For i = ir To 2 Step -1
   
6.     arr = Range(Cells(i, 1), Cells(i, 1).End(xlToRight))
   
7.     y = UBound(arr, 2)
   
8.     x = LBound(arr, 2)
   
9.     For j = y To x + 1 Step -1
   
10.          brr(ir - i + 1, y - j + 1) = arr(1, j)
    
11.     Next j
    
12.     Cells(ir - i + 2, 10) = ir - i + 1 ’自动编号
    
13. Next i
    
14. Cells(1, 10).Resize(1, 6) = [a1:f1].Value
    
15. Cells(2, 11).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    
16. End Sub

复制代码

autumnalRain

主要思路：将字典key对应的各个item，运用JOIN连接成长字符串，然后输出到工作表区域，并进行分列

autumnalRain

1. Sub TransposeArray()
   
2. arr = Sheet1.Range(Cells(1, 1), Cells(1, 1).End(xlDown))
   
3. Set d = CreateObject("SCRIPTING.DICTIONARY")
   
4. For i = 1 To UBound(arr)
   
5.     d(arr(i, 1)) = d(arr(i, 1)) & Join(Array(Cells(i, 3).Value, Cells(i, 4).Value, Cells(i, 5).Value, Cells(i, 6).Value, Cells(i, 7).Value, Cells(i, 8).Value, Cells(i, 9).Value), "|") & "|"
   
6. Next i
   
7. Sheet2.Cells(1, 1).Resize(d.Count, 1) = Application.Transpose(d.keys)
   
8. For i = 1 To d.Count
   
9.     Sheet2.Cells(i, 2) = d(Sheet2.Cells(i, 1).Value)
   
10. Next
    
11. Sheet2.[b:b].TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
    
12.     Tab:=True, Other:=True, OtherChar:="|"
    
13. End Sub

复制代码

补充内容 (2016-12-5 23:33):
第五行可以改为d(arr(i, 1)) = d(arr(i, 1)) & Join(Application.Transpose(Application.Transpose(Range(Cells(i, 3),cells(i,9))),"|")

autumnalRain

补充知识：
将单列数据单行数据连接成字符串的做法。join只能将一维数组连接成字符串

1. Sub TEST()
   
2.        A = Join(Application.Transpose([A1:A5]), "|")
   
3.        B = Join(Array([A10], [B10], [C10], [D10], [E10]), "|")
   
4. End Sub

复制代码

补充内容 (2016-12-5 23:28):
如果将单元格区域的一行用JOIN连接则需要：
C = Join(Application.Transpose(Application.Transpose([A1:A5])), "|")

autumnalRain

一个实例：运用JOIN将整列数据作为字符串进行比较，如果与A列完全相同，则删除

1. Sub test()
   
2. arr = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
   
3. s = Join(Application.Transpose(arr), "|")
   
4. For i = Range("a1").End(xlToRight).Column To 2 Step -1
   
5.     brr = Range(Cells(1, i), Cells(Rows.Count, i).End(xlUp))
   
6.     s1 = Join(Application.Transpose(brr), "|")
   
7.     If s1 = s Then
   
8.               numcol = numcol & "|" & i
   
9.               Columns(i).Delete SHIFT:=xlToLeft
   
10.           Else
    
11.               Sheet2.Cells(i, 1) = i
    
12.     End If
    
13. Next
    
14. Sheet2.Range("a1:a314").SpecialCells(xlCellTypeBlanks).Delete SHIFT:=xlUp
    
15. End Sub

复制代码

autumnalRain

下棋法之数据透视表式汇总,列数计算方法示例2与13楼第四个例子相对照，比较列数如何确定

1. Sub 下棋法之数据透视表式汇总()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. Dim 棋盘(1 To 10000, 1 To 7)
   
4. Dim 行数, 列数
   
5. Dim arr, x, k
   
6.   arr = Range("a2:f" & Range("a65536").End(xlUp).Row)
   
7.   For x = 1 To UBound(arr)
   
8.       sr = arr(x, 1) & arr(x, 2) & arr(x, 3) & arr(x, 4)
   
9.       列数 = (InStr("二库三库四库", arr(x, 6)) + 1) / 2 + 4
   
10.       If d.Exists(sr) Then
    
11.       行数 = d(sr)
    
12.       棋盘(行数, 列数) = 棋盘(行数, 列数) + arr(x, 5)
    
13.    Else
    
14.       k = k + 1
    
15.       d(sr) = k
    
16.       棋盘(k, 1) = arr(x, 1)
    
17.       棋盘(k, 2) = arr(x, 2)
    
18.       棋盘(k, 3) = arr(x, 3)
    
19.       棋盘(k, 4) = arr(x, 4)
    
20.       棋盘(k, 列数) = arr(x, 5)
    
21.    End If
    
22. Next x
    
23. With Sheet2
    
24.          .Activate
    
25.          .Columns(1).NumberFormatLocal = "@"
    
26.          .Range("a1").Resize(1, 8) = Array("物品代码", "物品名称", "规格", "单位", "二库", "三库", "四库", "汇总")
    
27.          .Range("a2").Resize(k, 7) = 棋盘
    
28.          .Range("H2").FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
    
29.          .Range("H2").AutoFill Destination:=Range("H2:H" & k + 1), Type:=xlFillDefault
    
30.   End With
    
31. End Sub

复制代码

autumnalRain

第八个例子：数据重排，多行数据重排为单行数据

1. Sub test()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. irow = [a1].End(xlDown).Row
   
4. For i = 1 To irow
   
5.      d(Cells(i, 1).Value) = s
   
6. Next i
   
7. Cells(irow + 10, 1).Resize(d.Count) = Application.Transpose(d.keys)
   
8. For k = 1 To d.Count
   
9.      For j = 1 To irow
   
10.           If Cells(irow + 10, 1).Offset(k - 1) = Cells(j, 1) Then
    
11.                    Range(Cells(j, 2), Cells(j, 1).End(xlToRight)).Copy Cells(irow + 10, 16384).Offset(k - 1, 0).End(xlToLeft).Offset(0, 1)
    
12.           End If
    
13.     Next j
    
14. Next k
    
15. End Sub

复制代码