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

autumnalRain

说明：本贴子只是个人收集归纳。无奈主题没有自定义，建议加个主题叫做“总结”或“归纳”吧，要不就得写成分享。但一般分享都是很有技术含量的东西，如果用到了哪位老师的代码忘记写出自哪里，请见谅！
============================================================================================================
第一个：将多行数据重排为单行数据。主要运用的知识点--ARRAY函数
http://club.excelhome.net/thread-1242204-1-1.html

1. Sub test()
   
2. For I = 3 To Sheet1.[A2].End(xlDown).Row
   
3.     For J = 2 To Sheet3.[A1].End(xlDown).Row
   
4.         With Sheet3
   
5.            If Sheet1.Cells(I, 2) & Sheet1.Cells(I, 7) = .Cells(J, 2) & .Cells(J, 4) Then
   
6.                  Sheet1.Cells(I, X + 21).Resize(1, 6) = Array(.Cells(J, 1), .Cells(J, 9), .Cells(J, 6), .Cells(J, 7), .Cells(J, 8), .Cells(J, 12))
   
7.                   X = X + 6
   
8.             End If
   
9.         End With
   
10.      Next J
    
11.       X = 0
    
12. Next I
    
13. End Sub

复制代码

补充内容 (2016-1-25 11:37):
希望此贴能涵盖大部分类型的行列转置情况，将来能当成本人的工具贴！

autumnalRain

第二个：代码出自zhong1218老师 。POWER QUERY也可实现。brr行数可以计算出……

1. Sub Transform()    Dim brr(1 To 1500, 1 To 3)
   
2.     brr(1, 1) = "班级": brr(1, 2) = "科目": brr(1, 3) = "教师"
   
3.     arr = Sheets("原始").Range("a1").CurrentRegion
   
4.     For i = 2 To UBound(arr, 2)
   
5.         For j = 2 To UBound(arr)
   
6.             If arr(j, i) <> "" Then
   
7.                 n = n + 1
   
8.                 brr(n + 1, 1) = arr(1, i)
   
9.                 brr(n + 1, 2) = arr(j, 1)
   
10.                 brr(n + 1, 3) = arr(j, i)
    
11.             End If
    
12.         Next j
    
13.     Next i
    
14.     Sheets("整理").Cells.ClearContents
    
15.     Sheets("整理").Range("a1").Resize(UBound(brr), 3) = brr
    
16. End Sub

复制代码

autumnalRain

第三个：这个例子因为数据不够规范，比如同列>>数据类型不同，数据稀疏NULL值等 ，所以用VBA SQL需要重新加工数据。略过此法

1. Dim d As Object

复制代码

1. Sub 装入字典()
   
2.     Dim r As Integer
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     r = 2
   
5.     With Sheet1
   
6.        Do While .Cells(r, 1) <> ""
   
7.           If .Cells(r, 1).Value <> "小计:" Then
   
8.              d(.Cells(r, 1).Value) = ""
   
9.           End If
   
10.           r = r + 1
    
11.        Loop
    
12.     End With
    
13. End Sub

复制代码

1. Sub 写行列标题()
   
2.     Sheets.Add after:=Sheet1
   
3.     ActiveSheet.Name = "最终格式"
   
4.     [a1:f1] = Array("设备号码", "固定电话月租费", "来电显示", "区内通话费", "区间通话费", "传统国内长途费")
   
5.     [a2].Resize(d.Count) = Application.Transpose(d.keys)
   
6. End Sub

复制代码

1. Sub 写入数据()
   
2.     Dim arr, brr,  dic As Object, i&, j&
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     arr = Sheet1.Range("a1").CurrentRegion '原始数据
   
5.     brr = Sheets("最终格式").Range("a1").CurrentRegion '目标数据
   
6. 
   
7.     For i = 2 To UBound(arr, 1)
   
8.         If arr(i, 1) <> "小计:" Then
   
9.               dic(arr(i, 1) & "|" & arr(i, 2)) = arr(i, 3)
   
10.         End If
    
11.     Next
    
12.     'Sheet1.Range("A40").Resize(UBound(dic.keys) + 1, 2) = Application.Transpose(Array(dic.keys, dic.items))
    
13.         For i = 2 To UBound(brr, 1)
    
14.         For j = 2 To UBound(brr, 2)
    
15.                brr(i, j) = dic(brr(i, 1) & "|" & brr(1, j))
    
16.         Next
    
17.     Next
    
18.      Sheets("最终格式").Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
19. End Sub

复制代码

autumnalRain

第三个例子，下棋法代码，代码出自yeminqiang老师。

1. Sub 下棋法之数据透视表式汇总()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. Dim 棋盘(1 To 10000, 1 To 6)
   
4. Dim 行数, 列数
   
5. Dim arr, x, k
   
6. arr = Range("a2:g" & Range("a65536").End(xlUp).Row)
   
7.   For x = 1 To UBound(arr)
   
8.   列数 = (InStr("费用来电区内区间传统", Left(arr(x, 2), 2)) + 1) / 2 + 1
   
9.   If arr(x, 1) <> "小计:" Then
   
10.     If d.Exists(arr(x, 1)) Then
    
11.       行数 = d(arr(x, 1))
    
12.       棋盘(行数, 列数) = 棋盘(行数, 列数) + arr(x, 3)
    
13.    Else
    
14.       k = k + 1
    
15.       d(arr(x, 1)) = k
    
16.       棋盘(k, 1) = arr(x, 1)
    
17.       棋盘(k, 列数) = arr(x, 3)
    
18.    End If
    
19.    End If
    
20. Next x
    
21. Range("J2").Resize(k, 6) = 棋盘
    
22. End Sub

复制代码

renahu

autumnalRain 发表于 2015-12-4 09:48
第三个例子，下棋法代码，代码出自yeminqiang老师

下棋法，点按钮1提示下标越界

autumnalRain

renahu 发表于 2015-12-4 11:41
下棋法，点按钮1提示下标越界

这个例子是其他老师的代码。兰色幻想老师的下棋法代码通用性很强，可以套写。请参考兰色老师下棋法代码。见附件！

renahu

autumnalRain 发表于 2015-12-4 09:48
第三个例子，下棋法代码，代码出自yeminqiang老师。抱歉，还没有找到出处就点了保存

此附件中的 zhong1218老师代码   有错误，brr数组下限的问题，不知道跟 下棋法之数据透视表式汇总 有什么关联？是不是用的也是下棋法？

autumnalRain

renahu 发表于 2015-12-4 12:43
此附件中的 zhong1218老师代码   有错误，brr数组下限的问题，不知道跟 下棋法之数据透视表式汇总 有什么 ...

http://club.excelhome.net/forum. ... 1&extra=#pid8448597
第二个例子，我重新试了下，没有问题啊，看下原贴吧。这个例子没有用下棋法，纯数组方法解决；
下棋法是数组和字典的综合运用。第二个例子第二种方法用的是下棋法。

renahu

autumnalRain 发表于 2015-12-4 13:20
http://club.excelhome.net/forum. ... 1&extra=#pid8448597
第二个例子，我重新试了下，没有问题啊，看 ...

是第三个例子，附件是“下棋法”，点击sheet1的按钮1

yeminqiang

autumnalRain 发表于 2015-12-4 09:48
第三个例子，下棋法代码，代码出自yeminqiang老师。抱歉，还没有找到出处就点了保存

代码不是我原创，我也只是改的。