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

autumnalRain

1. Sub tp() 'By cnzjjhzjf
   
2. Dim arr, brr(), n%
   
3. arr = Sheet1.Range("A3:H" & Sheet1.Range("A65536").End(xlUp).Row)
   
4. For i = 1 To UBound(arr)
   
5.     For j = 1 To 5
   
6.         If Trim(arr(i, j + 3)) <> "" Then
   
7.             n = n + 1
   
8.             ReDim Preserve brr(1 To 4, 1 To n)
   
9.             brr(1, n) = n
   
10.             brr(2, n) = arr(i, 2)
    
11.             brr(3, n) = arr(i, j + 3)
    
12.             brr(4, n) = arr(i, 3)
    
13.         Else
    
14.             Exit For
    
15.         End If
    
16.     Next j
    
17. Next i
    
18. Sheet1.Range("K3").Resize(UBound(brr, 2), UBound(brr)) = Application.WorksheetFunction.Transpose(brr)
    
19. End Sub

复制代码

529905149

膜拜版主，学无止境

wdzhida

留下学习,厉害.

Defei

总结的很用心～帖子很好送花

Defei

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

谦虚了，写出来就是你的了。

autumnalRain

autumnalRain 发表于 2015-12-7 15:52
20楼Yaong_3老师的构思很巧妙，一个变量把行列以及数组的元素位置全部联系在一起了

用数组方法。
注意：一列转多列的情况都是如此。
ARR数组不管下标是不是从0开始,第7行代码都要从0开始循环。
如果第6行代码为For i = 1 To UBound(arr) ，则第7行代码需要改为  brr(Int(（i-1 ）/ 4), (（i -1） Mod 4) + 1) = arr(i , 1)

1. Sub TEST()
   
2.   Dim arr, brr(), m, i
   
3.   arr = Range([a1], [a1].End(4))
   
4.   m = UBound(arr) / 4-1
   
5.   ReDim brr(0 To m, 1 To 4)
   
6.   For i = 0 To UBound(arr) - 1
   
7.     brr(Int(i / 4), (i Mod 4) + 1) = arr(i + 1, 1)
   
8.   Next
   
9.   Sheet2.Cells(1, 1).Resize(UBound(brr)+1 , 4) = brr
   
10. End Sub
    

复制代码

待8缘

感谢分享！！！

陈功

感谢分享！！！

autumnalRain

1. Sub test()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     arr = Sheets(1).UsedRange
   
5.     For i = 2 To UBound(arr, 1)
   
6.         d(arr(i, 4)) = d(arr(i, 4)) & "," & arr(i, 51)
   
7.         Set dic(arr(i, 4)) = Range(Cells(i, 2), Cells(i, 45))
   
8.     Next
   
9.     For j = 0 To d.Count - 1
   
10.         dic.items()(j).Copy Sheets(2).[b1048576].End(xlUp).Offset(1)
    
11.         brr = Split(Mid(d.items()(j), 2), ",")
    
12.         Sheets(2).Cells(j + 2, 1) = "招-" & j + 1
    
13.         Sheets(2).Cells(j + 2, 46).Resize(, UBound(brr) + 1) = brr
    
14.     Next
    
15. End Sub

复制代码

imroy

autumnalRain 发表于 2017-7-25 15:25

你好，有没有适合我这种情况的？http://club.excelhome.net/thread-1359142-1-1.html