能否帮忙自动转置

luppie

表格见附件。

原始数据很多，需要转置一下。

我用transpose手动转比较累，后面还有几年的数据。

想用vba自动完成转置，但是对我比较难，专家能否指点指点我。

主要是自动获取转置区域对我来说有难度。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     With Worksheets("原始数据")
   
5.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.         arr = .Range("a2:d" & r)
   
7.         ReDim brr(1 To UBound(arr) / 24, 1 To 26)
   
8.         m = 0
   
9.         For i = 1 To UBound(arr) Step 24
   
10.             m = m + 1
    
11.             brr(m, 1) = m
    
12.             brr(m, 2) = arr(i, 2)
    
13.             For k = 1 To 24
    
14.                 brr(m, k + 2) = arr(i + k - 1, 4)
    
15.             Next
    
16.         Next
    
17.     End With
    
18.     With Worksheets("转换结果")
    
19.         .UsedRange.Offset(1, 0).Clear
    
20.         .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
21.     End With
    
22. End Sub
    

复制代码

chxw68

数据很整齐。

ooluckydog

luppie

哇塞，各位专家，谢谢你们啦，太热情了。

感动感动！！！敬谢！祝各位专家身体健康生活愉快！

ykcbf1100

字典+数组写一个。
如果数据中间有缺少，或者数据排序不那么规整，那就得用我这个办法了。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.29
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("原始数据")
   
6.         r = .Cells(Rows.Count, "b").End(3).Row
   
7.         arr = .[a1].Resize(r, 4)
   
8.     End With
   
9.     ReDim brr(1 To 10000, 1 To 100)
   
10.     m = 1: n = 2
    
11.     brr(1, 1) = "序号": brr(1, 2) = "日期"
    
12.     For i = 2 To UBound(arr)
    
13.         s = CStr(arr(i, 2))
    
14.         If Not d.exists(s) Then
    
15.             m = m + 1
    
16.             d(s) = m
    
17.             brr(m, 1) = m - 1
    
18.             brr(m, 2) = CStr(arr(i, 2))
    
19.         End If
    
20.         s = CStr(arr(i, 3))
    
21.         If Not d.exists(s) Then
    
22.             n = n + 1
    
23.             d(s) = n
    
24.             brr(1, n) = s
    
25.         End If
    
26.         r = d(arr(i, 2)): c = d(arr(i, 3))
    
27.         brr(r, c) = arr(i, 4)
    
28.     Next
    
29.     With Sheets("转换结果")
    
30.         .Cells.Clear
    
31.         .[a1].Resize(1, n).Interior.Color = 49407
    
32.         .[c1].Resize(1, n - 2).NumberFormatLocal = "hh:ss"
    
33.         With .[a1].Resize(m, n)
    
34.             .Value = brr
    
35.             .Borders.LineStyle = 1
    
36.             .HorizontalAlignment = xlCenter
    
37.             .VerticalAlignment = xlCenter
    
38.         End With
    
39.     End With
    
40.     Set d = Nothing
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "OK！"
    
43. End Sub
    

复制代码

luppie

ooluckydog 发表于 2024-4-29 11:36

帅哥，没理解我的意思，把全部数据转置成一行了。

但是没关系，已经是小问题了，剩下我知道怎么修正一下。

太谢谢了！！！

luppie

chxw68 发表于 2024-4-29 11:35

老师，你这种属于完美解答啊，学生超越的空间一点不留啊。哈哈。谢谢老师！！！