数据转置问题

779846526

哪位帮忙写个 转换.zip (119.75 KB, 下载次数: 12)

2019-1-19 18:42 上传

点击文件名下载附件

数据转置代码

liulang0808

代码供参考。。。。。。

779846526

liulang0808 发表于 2019-1-19 19:01
代码供参考。。。。。。

谢谢版主的回贴，再次谢谢

719404338

1. Sub t()
   
2. Dim i, j, d, k
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. k = 1
   
5. Sheet2.Activate
   
6. For i = 9 To 15 Step 3
   
7.    For j = 5 To 68
   
8.    If Cells(i, j) <> "" Then
   
9.    d("" & k) = Array(Range("c" & i), Cells(i, j), Cells(7, j), Cells(i + 2, j), Cells(i + 1, j))
   
10.    k = k + 1
    
11.    End If
    
12. Next j, i
    
13.    Sheet6.Activate
    
14.    [a1:e1] = Array("节次", "课程", "教室", "教师", "学生人数")
    
15.    i = 2
    
16.    For Each sj In d.Items
    
17.    Range("a" & i & ":e" & i) = sj
    
18.    i = i + 1
    
19.    Next
    
20. End Sub
    

复制代码

这个不难。

everbest2015

Sub My转换()
     Dim ar, br(), i&, r&, k&, s$, t, tt!
    tt = Timer
    r = Sheet2.Range("e" & Rows.Count).End(xlUp).Row - 6
    ar = Sheet2.Range("C7").Resize(r, 66)
    r = 0
    ReDim br(1 To 1000, 1 To 5)
    t = [{"节次","课程","教室","教师","学生人数"}]
    Sheet4.Range("a1").Resize(, UBound(t)) = t
    For i = 3 To UBound(ar) Step 3
        For k = 3 To UBound(ar, 2)
            s = ar(i, k)
            If s <> "" Then
                r = r + 1
                br(r, 1) = ar(i, 1)
                br(r, 2) = s
                br(r, 3) = ar(1, k)
                br(r, 4) = ar(i + 2, k)
                br(r, 5) = ar(i + 1, k)
            End If
        Next
    Next
    If r > 0 Then
    Application.ScreenUpdating = False
            Sheet4.Range("a2").Resize(r, UBound(t)) = ""
            Sheet4.Range("a2").Resize(r, UBound(t)) = br
'            With Sheet4.Range("A:E")
'                .HorizontalAlignment = xlCenter
'                .VerticalAlignment = xlCenter
'                .EntireColumn.AutoFit
'                .Borders.LineStyle = xlContinuous
'            End With
            MsgBox "亲~数据转换成功" & Chr(10) & "程序共运行" & _
            Format(Timer - tt, "0.00") & "秒", 64, "新年快乐"
    Application.ScreenUpdating = True
    End If
End Sub

everbest2015

with 语句内容已被注释,测试0.02秒