[已解决]二维数组转置问题

hbjxgsq

二维数组转置.rar (4.02 KB, 下载次数: 13)

2014-6-22 08:39 上传

点击文件名下载附件 二维数组转置，生成sheet2的样式，请论坛的老师们帮助解答！谢谢！请用VBA解答！谢谢！

最佳答案

月排行榜 / 总排行榜

雪舞子

2014-6-23 10:01

运用了字典套字典，三维数组

1. Sub test()
   
2.     Dim arr, ar, brr(), br(), i%, m%, n%, k%
   
3.     Dim d As Object
   
4.     ReDim brr(1 To 10, 1 To 10, 1 To 100)
   
5.     '结果数组:第一维大分类(A,B...),第二维小分类(x,y...),第三维转置后数据
   
6. 
   
7.     Set d = CreateObject("Scripting.Dictionary")    '定义字典
   
8.     arr = Sheet1.Range("a1").CurrentRegion
   
9.     For i = 2 To UBound(arr)    '从数据源第2行开始处理
   
10.         If Not d.exists(arr(i, 2)) Then
    
11.             '第一步将第二列,即A,B...作为关键字建立字典
    
12. 
    
13.             m = m + 1: n = 0  'm为大分类(A,B...)计数,n为小分类(x,y...)计数
    
14.             Set d(arr(i, 2)) = CreateObject("Scripting.Dictionary")
    
15.             '第一步建立字典后,将d.item再建立字典(子字典),用于盛放大分类下小分类(x,y.....)
    
16. 
    
17.         End If
    
18.         If Not d(arr(i, 2)).exists(arr(i, 3)) Then
    
19.             '上面建立了子字典,这时开始盛放数据,子字典的关键字为小分类(x,y....)
    
20. 
    
21.             n = n + 1: k = 1       'n为小分类计数,k为数据计数
    
22.             brr(m, n, 1) = arr(1, 3) & arr(i, 3)          'brr(大分类,小分类,数据),这里结果"分类X"
    
23.             d(arr(i, 2))(arr(i, 3)) = Array(m, n)    '子字典的 items 为二维数组计数 array(大分类记数,小分类记数)
    
24.         End If
    
25.         k = k + 1    '数据计数累加
    
26.         brr(d(arr(i, 2))(arr(i, 3))(0), d(arr(i, 2))(arr(i, 3))(1), k) = arr(i, 1)
    
27.         'brr为结果数组:将子字典的items值(大分类,小分类计数值)拿出来作为三维数组下标,这样可以知道每个数据属于哪个分类
    
28. 
    
29.     Next
    
30.     arr = d.keys: k = 0: m = 1    'arr大分类数组,就这么多,k,m联合控制目标数组行数
    
31.     For i = 0 To UBound(arr)     '循环一下赋给结果数组ar
    
32.         k = k + m                '第一大类开始行
    
33.         ReDim Preserve br(1 To UBound(brr, 3) + 1, 1 To k)
    
34.         '定义结果数组,小分类从第二列开始摆数据,最后要多一列(UBound(brr, 3) + 1)
    
35. 
    
36.         br(1, k) = arr(i)
    
37.         ar = d(arr(i)).keys   'ar小分类数组,就这么多行(ubound(ar))
    
38.         For m = 1 To UBound(ar) + 1   '循环小分类,由于ar下标从0开始,因此+1
    
39.             For n = 1 To UBound(brr, 3)   '循环数据
    
40.                 ReDim Preserve br(1 To UBound(brr, 3) + 1, 1 To k + m)
    
41.                 '结果数组从第二列开始摆数据 ,因此(UBound(brr, 3) + 1)
    
42. 
    
43.                 br(n + 1, k + m) = brr(i + 1, m, n)  '目标数据全部输出给结果数组
    
44.             Next
    
45.         Next
    
46.     Next
    
47.     With Sheet2.Range("a1")
    
48.         .CurrentRegion.ClearContents
    
49.         .Value = "数组转置"
    
50.         .Offset(1).Resize(UBound(br, 2), UBound(br)) = Application.Transpose(br)   '输出结果
    
51.     End With
    
52. End Sub
    

复制代码

二维数组转置.rar (13.6 KB, 下载次数: 17)

2014-6-23 10:01 上传

点击文件名下载附件

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr(1 To 20000, 1 To 3), d, d2, i&, zf$, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Sheet1.Range("a1").CurrentRegion
   
6. For i = 2 To UBound(arr)
   
7.     d(arr(i, 2)) = ""
   
8.     zf = arr(i, 2) & "," & arr(1, 3) & arr(i, 3)
   
9.     If Not d2.exists(zf) Then d2(zf) = arr(i, 1) Else d2(zf) = d2(zf) & "," & arr(i, 1)
   
10. Next
    
11. a = d.keys: a2 = d2.keys: b2 = d2.items
    
12. For i = 0 To d.Count - 1
    
13.     s = s + 1
    
14.     brr(s, 1) = a(i)
    
15.     For j = 0 To d2.Count - 1
    
16.         x = Split(a2(j), ",")
    
17.         If x(0) = a(i) Then s = s + 1: brr(s, 2) = x(1): brr(s, 3) = b2(j)
    
18.     Next
    
19. Next
    
20. Sheet2.Activate
    
21. Range("a1").Resize(s, 3) = brr
    
22. [c:c].TextToColumns Destination:=[c1], Other:=True, OtherChar:=","
    
23. End Sub
    

复制代码

dsmch

………………

雪舞子

运用了字典套字典，三维数组

1. Sub test()
   
2.     Dim arr, ar, brr(), br(), i%, m%, n%, k%
   
3.     Dim d As Object
   
4.     ReDim brr(1 To 10, 1 To 10, 1 To 100)
   
5.     '结果数组:第一维大分类(A,B...),第二维小分类(x,y...),第三维转置后数据
   
6. 
   
7.     Set d = CreateObject("Scripting.Dictionary")    '定义字典
   
8.     arr = Sheet1.Range("a1").CurrentRegion
   
9.     For i = 2 To UBound(arr)    '从数据源第2行开始处理
   
10.         If Not d.exists(arr(i, 2)) Then
    
11.             '第一步将第二列,即A,B...作为关键字建立字典
    
12. 
    
13.             m = m + 1: n = 0  'm为大分类(A,B...)计数,n为小分类(x,y...)计数
    
14.             Set d(arr(i, 2)) = CreateObject("Scripting.Dictionary")
    
15.             '第一步建立字典后,将d.item再建立字典(子字典),用于盛放大分类下小分类(x,y.....)
    
16. 
    
17.         End If
    
18.         If Not d(arr(i, 2)).exists(arr(i, 3)) Then
    
19.             '上面建立了子字典,这时开始盛放数据,子字典的关键字为小分类(x,y....)
    
20. 
    
21.             n = n + 1: k = 1       'n为小分类计数,k为数据计数
    
22.             brr(m, n, 1) = arr(1, 3) & arr(i, 3)          'brr(大分类,小分类,数据),这里结果"分类X"
    
23.             d(arr(i, 2))(arr(i, 3)) = Array(m, n)    '子字典的 items 为二维数组计数 array(大分类记数,小分类记数)
    
24.         End If
    
25.         k = k + 1    '数据计数累加
    
26.         brr(d(arr(i, 2))(arr(i, 3))(0), d(arr(i, 2))(arr(i, 3))(1), k) = arr(i, 1)
    
27.         'brr为结果数组:将子字典的items值(大分类,小分类计数值)拿出来作为三维数组下标,这样可以知道每个数据属于哪个分类
    
28. 
    
29.     Next
    
30.     arr = d.keys: k = 0: m = 1    'arr大分类数组,就这么多,k,m联合控制目标数组行数
    
31.     For i = 0 To UBound(arr)     '循环一下赋给结果数组ar
    
32.         k = k + m                '第一大类开始行
    
33.         ReDim Preserve br(1 To UBound(brr, 3) + 1, 1 To k)
    
34.         '定义结果数组,小分类从第二列开始摆数据,最后要多一列(UBound(brr, 3) + 1)
    
35. 
    
36.         br(1, k) = arr(i)
    
37.         ar = d(arr(i)).keys   'ar小分类数组,就这么多行(ubound(ar))
    
38.         For m = 1 To UBound(ar) + 1   '循环小分类,由于ar下标从0开始,因此+1
    
39.             For n = 1 To UBound(brr, 3)   '循环数据
    
40.                 ReDim Preserve br(1 To UBound(brr, 3) + 1, 1 To k + m)
    
41.                 '结果数组从第二列开始摆数据 ,因此(UBound(brr, 3) + 1)
    
42. 
    
43.                 br(n + 1, k + m) = brr(i + 1, m, n)  '目标数据全部输出给结果数组
    
44.             Next
    
45.         Next
    
46.     Next
    
47.     With Sheet2.Range("a1")
    
48.         .CurrentRegion.ClearContents
    
49.         .Value = "数组转置"
    
50.         .Offset(1).Resize(UBound(br, 2), UBound(br)) = Application.Transpose(br)   '输出结果
    
51.     End With
    
52. End Sub
    

复制代码

二维数组转置.rar (13.6 KB, 下载次数: 17)

2014-6-23 10:01 上传

点击文件名下载附件

雪舞子

1. Sub test()
   
2.     Dim arr, ar, brr(), br(), i%, m%, n%, k%
   
3.     Dim d As Object
   
4.     ReDim brr(1 To 10, 1 To 10, 1 To 100)
   
5.     '结果数组:第一维大分类(A,B...),第二维小分类(x,y...),第三维转置后数据
   
6. 
   
7.     Set d = CreateObject("Scripting.Dictionary")    '定义字典
   
8.     arr = Sheet1.Range("a1").CurrentRegion
   
9.     For i = 2 To UBound(arr)    '从数据源第2行开始处理
   
10.         If Not d.exists(arr(i, 2)) Then
    
11.             '第一步将第二列,即A,B...作为关键字建立字典
    
12. 
    
13.             m = m + 1: n = 0  'm为大分类(A,B...)计数,n为小分类(x,y...)计数
    
14.             Set d(arr(i, 2)) = CreateObject("Scripting.Dictionary")
    
15.             '第一步建立字典后,将d.item再建立字典(子字典),用于盛放大分类下小分类(x,y.....)
    
16. 
    
17.         End If
    
18.         If Not d(arr(i, 2)).exists(arr(i, 3)) Then
    
19.             '上面建立了子字典,这时开始盛放数据,子字典的关键字为小分类(x,y....)
    
20. 
    
21.             n = n + 1: k = 1       'n为小分类计数,k为数据计数
    
22.             brr(m, n, 1) = arr(1, 3) & arr(i, 3)          'brr(大分类,小分类,数据),这里结果"分类X"
    
23.             d(arr(i, 2))(arr(i, 3)) = Array(m, n, 2) '子字典的 items 为二维数组计数 array(大分类记数,小分类记数)
    
24.         End If
    
25.          '数据计数累加
    
26.         brr(d(arr(i, 2))(arr(i, 3))(0), d(arr(i, 2))(arr(i, 3))(1), d(arr(i, 2))(arr(i, 3))(2)) = arr(i, 1)
    
27.         'brr为结果数组:将子字典的items值(大分类,小分类计数值)拿出来作为三维数组下标,这样可以知道每个数据属于哪个分类
    
28.         
    
29.         d(arr(i, 2))(arr(i, 3)) = Array(d(arr(i, 2))(arr(i, 3))(0), d(arr(i, 2))(arr(i, 3))(1), d(arr(i, 2))(arr(i, 3))(2) + 1)
    
30.         '数据计数累加后还给字典
    
31.     Next
    
32.     arr = d.keys: k = 0: m = 1    'arr大分类数组,就这么多,k,m联合控制目标数组行数
    
33.     For i = 0 To UBound(arr)     '循环一下赋给结果数组ar
    
34.         k = k + m                '第一大类开始行
    
35.         ReDim Preserve br(1 To UBound(brr, 3) + 1, 1 To k)
    
36.         '定义结果数组,小分类从第二列开始摆数据,最后要多一列(UBound(brr, 3) + 1)
    
37. 
    
38.         br(1, k) = arr(i)
    
39.         For m = 1 To d(arr(i)).Count '循环小分类
    
40.             For n = 1 To UBound(brr, 3)   '循环数据
    
41.                 ReDim Preserve br(1 To UBound(brr, 3) + 1, 1 To k + m)
    
42.                 '结果数组从第二列开始摆数据 ,因此(UBound(brr, 3) + 1)
    
43. 
    
44.                 br(n + 1, k + m) = brr(i + 1, m, n)  '目标数据全部输出给结果数组
    
45.             Next
    
46.         Next
    
47.     Next
    
48.     With Sheet2.Range("a1")
    
49.         .CurrentRegion.ClearContents
    
50.         .Value = "数组转置"
    
51.         .Offset(1).Resize(UBound(br, 2), UBound(br)) = Application.Transpose(br)   '输出结果
    
52.     End With
    
53. End Sub
    

复制代码

二维数组转置.rar (10.55 KB, 下载次数: 14)

2014-6-23 11:06 上传

点击文件名下载附件

hbjxgsq

谢谢楼上的两位老师,结果都很准确!向您们学习了!
不好意思,回复晚了!