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

autumnalRain

yeminqiang 发表于 2015-12-4 17:38
代码不是我原创，我也只是改的。

呵呵，也许是我在意了，总以为拿别人的代码写到自己的贴子上对人不尊重。对我来说是重要的内容，要收藏起来！

在和弦处等你

autumnalRain 发表于 2015-12-4 09:29

用Power Query了，就别再VBA了

autumnalRain

重点是列数如何确定。分析如下：
************************************************************************************************************************************
列数 = (InStr("1月2月3月4月5月6月", arr(x, 2)) + 1) / 2 + 1
-----------------------------------------------------------------------------------------------------------------------------------------
第一步、确定棋盘中已占用的列数，这里为1，存放产品名称
-----------------------------------------------------------------------------------------------------------------------------------------
第二步、确定应放在已占用列后的第几列
arr(x, 2)是2个字符的字符串，后面除以2，得出把两个字符视同一个整体时的所在的位置，这里字符串长度为几就除以几；若实际字符长度不一，可以用left、mid、
或right等字符串函数获致其部分关键字，并根据关键字的长度判断应该除以2或是其它的数字
-----------------------------------------------------------------------------------------------------------------------------------------
第三步、确定该字符应该在棋盘中出现的列的位置
通过原有列数+第二步得现的位置数字
-----------------------------------------------------------------------------------------------------------------------------------------
比如当arr(x, 2)=“2月”时，其位置为3，加1，除以2后等于2，得出其在字符串的位置（两个字符视同一个位置），加上红色字体1为原有列数，所以2月应在棋盘的第3列
*****************************************************************************************************************************************************

参考29楼列数计算的另一个例子

1. Option Explicit

复制代码

1. Sub 下棋法之数据透视表式汇总()
   
2. Dim d As New Dictionary
   
3. Dim 棋盘(1 To 10000, 1 To 7)
   
4. Dim 行数, 列数
   
5. Dim arr, x, k
   
6.   arr = Range("a2:c" & Range("a65536").End(xlUp).Row)
   
7.   For x = 1 To UBound(arr)
   
8.    列数 = (InStr("1月2月3月4月5月6月", arr(x, 2)) + 1) / 2 + 1
   
9.    If d.Exists(arr(x, 1)) Then
   
10.       行数 = d(arr(x, 1))
    
11.       棋盘(行数, 列数) = 棋盘(行数, 列数) + arr(x, 3)
    
12.    Else
    
13.       k = k + 1
    
14.       d(arr(x, 1)) = k
    
15.       棋盘(k, 1) = arr(x, 1)
    
16.       棋盘(k, 列数) = arr(x, 3)
    
17.    End If
    
18. Next x
    
19.   Range("f2").Resize(k, 7) = 棋盘
    
20. End Sub

复制代码

autumnalRain

我的笨方法

1. Dim dic As Object

复制代码

1. Sub 装入字典()
   
2.     Dim r As Integer
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     r = 1
   
5.     Do While Cells(r, 1) <> ""
   
6.         dic(Cells(r, 1).Value) = ""
   
7.         r = r + 1
   
8.     Loop
   
9. End Sub

复制代码

1. Sub 写行列标题()
   
2.     [g1:l1] = Array("1月", "2月", "3月", "4月", "5月", "6月")
   
3.     [f1].Resize(dic.Count) = Application.Transpose(dic.Keys)
   
4. End Sub

复制代码

1. Sub 交叉汇总()
   
2. arr = [a1].CurrentRegion
   
3. Set d = CreateObject("scripting.dictionary")
   
4. For i = 2 To UBound(arr)
   
5.     d(arr(i, 1) & arr(i, 2)) = d(arr(i, 1) & arr(i, 2)) + arr(i, 3)
   
6. Next
   
7. brr = [f1].CurrentRegion
   
8. For x = 2 To UBound(brr)
   
9.    For y = 2 To UBound(brr, 2)
   
10.        brr(x, y) = d(brr(x, 1) & brr(1, y))
    
11.     Next y
    
12. Next x
    
13. [f1].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    
14. End Sub

复制代码

autumnalRain

1. Sub 查询结果()
   
2. Dim cnn As Object, SQL
   
3. Set cnn = CreateObject("ADODB.Connection")
   
4. cnn.Open "provider=microsoft.ACE.OLEDB.12.0;extended properties='Excel 12.0;hdr=yes';data source=" & ThisWorkbook.FullName
   
5. SQL = "transform sum(费用) select 产品 from [数据透视表式汇总$] group by 产品 pivot 月份"
   
6. Sheets("查询结果").[a2].CopyFromRecordset cnn.Execute(SQL)
   
7. cnn.Close
   
8. Set cnn = Nothing
   
9. End Sub

复制代码

autumnalRain

单纯用EXCEL SQL 方法：
transform sum(费用) select 产品 from [数据透视表式汇总$] group by 产品 pivot 月份

autumnalRain

就第四个例子来讲，如果单独实现数据透视表式分类汇总，EXCEL SQL方法是最简单的

autumnalRain

第五个例子：将A列以“/”分隔的内容填充到宽25列的区域中

1. Sub zz() ‘By zax010
   
2.     Dim ar, br(1 To 2000, 1 To 25)
   
3.     ar = Range("A1").CurrentRegion
   
4.     For i = 1 To UBound(ar)
   
5.         s = Split(ar(i, 1), "/")
   
6.         For j = 0 To UBound(s)
   
7.             br(1 + m, 1 + k) = s(j)
   
8.             k = k + 1
   
9.             If k = 25 Then
   
10.                 m = m + 1
    
11.                 k = 0
    
12.             End If
    
13.         Next
    
14.     Next
    
15.     [j19].Resize(m + 1, 25) = br
    
16. End Sub

复制代码

autumnalRain

1. Sub test()
   
2. Dim arr,i, sr, s, k, u, b, x, y
   
3. arr = [a1].CurrentRegion
   
4. On Error Resume Next
   
5. For i = 1 To UBound(arr)
   
6.     sr = sr & "/" & arr(i, 1)
   
7. Next i
   
8. s = Split(Right(sr, Len(sr) - 1), "/")
   
9. k = UBound(s)+1
   
10. u = Application.RoundUp(k / 25, 0)
    
11. b = 0
    
12. For x = 1 To u
    
13.     For y = 1 To 25
    
14.         Cells(x + 18, y + 9) = s(b)
    
15.         b = b + 1
    
16.     Next y
    
17. Next x
    
18. End Sub

复制代码

autumnalRain

1. Sub yy() By Yaong_3
   
2. Dim Arr, Str$, i&
   
3. Str = Range("A1")
   
4. For i = 2 To [A65536].End(xlUp).Row
   
5. Str = Str & "/" & Cells(i, 1)
   
6. Next
   
7. Arr = Split(Str, "/")
   
8. For i = 0 To UBound(Arr)
   
9.     Cells(Int(i / 25) + 19, (i Mod 25) + 10) = Arr(i)
   
10. Next i
    
11. End Sub

复制代码

补充内容 (2017-1-16 16:56):
一列转多列的情况都是如此。注意ARR数组不管是不是下标从0开始都要从0开始循环。如下标为1则循环时可以用 For i = 0 To UBound(Arr) - 1
   

补充内容 (2017-1-16 16:58):
Cells(Int(i / 25) + 19, (i Mod 25) + 10) = Arr(i)

这里的19指从第19行开始，10表示从第10列开始