课表变换

779846526

求助好心人写个课表变换代码：第1次运行代码后能将原始课表转换成分行课表样表一样的课表（课程与教师名分2行去填写），第2次运行后能还原原始课表的样子，第3次运行又变成分行课表。                                       
                                       
                                       
                                       
                                       
                                       
                                       
                                       
                                       
                                       
2016-2017上学期总功课表2.zip (20.46 KB, 下载次数: 14)

2016-10-10 11:25 上传

点击文件名下载附件

microyip

这种不就是瞎折腾的需求啊？

chxw68

楼主是不是有两个马甲？前面刚帮别人写过。

779846526

chxw68 发表于 2016-10-10 11:35
楼主是不是有两个马甲？前面刚帮别人写过。

谢谢您的多次相助啊，是有2个啊，有一段时间这个不记得密码，就再注册了个，我在用时发现还有一处想请您帮我改下，就是转换成课程教师名分行填写时，班级单元格没合并啊

microyip

1. Sub 瞎折腾()
   
2.     Dim vData As Variant, iRow As Integer, iCol As Integer, vFill As Variant
   
3.    
   
4.     Application.ScreenUpdating = False
   
5.     iRow = Sheet1.UsedRange.Rows.Count
   
6.     iCol = [B4].CurrentRegion.Columns.Count
   
7.     vData = [B4].Offset(0, -1).Resize(iRow - 3, iCol).Value
   
8.     Rows("4:" & iRow).Delete
   
9.     If vData(2, 1) = "" Then
   
10.         ReDim vFill(1 To UBound(vData) / 2, 1 To iCol)
    
11.         For iRow = 1 To UBound(vData) / 2
    
12.             For iCol = 1 To UBound(vData, 2)
    
13.                 vFill(iRow, iCol) = vData(iRow * 2 - 1, iCol)
    
14.                 vFill(iRow, iCol) = vFill(iRow, iCol) & Chr(10) & vData(iRow * 2, iCol)
    
15.             Next
    
16.         Next
    
17.     Else
    
18.         ReDim vFill(1 To UBound(vData) * 2, 1 To iCol)
    
19.         For iRow = 1 To UBound(vData)
    
20.             For iCol = 1 To UBound(vData, 2)
    
21.                 If Not IsEmpty(vData(iRow, iCol)) Then
    
22.                     vData(iRow, iCol) = Split(vData(iRow, iCol), Chr(10))
    
23.                     vFill(iRow * 2 - 1, iCol) = vData(iRow, iCol)(0)
    
24.                     If UBound(vData(iRow, iCol)) = 1 Then vFill(iRow * 2, iCol) = vData(iRow, iCol)(1)
    
25.                 End If
    
26.             Next
    
27.         Next
    
28.     End If
    
29.     [B4].Offset(0, -1).Resize(UBound(vFill), UBound(vFill, 2)) = vFill
    
30.     If UBound(vData) < UBound(vFill) Then
    
31.         For iRow = 1 To UBound(vFill) / 2
    
32.             Cells(iRow * 2 + 2, 1).Resize(2, 1).Merge
    
33.         Next
    
34.     End If
    
35.     Rows.AutoFit
    
36.     Application.ScreenUpdating = True
    
37. End Sub
    

复制代码

microyip

附上附件以供参考

779846526

microyip 发表于 2016-10-10 12:54
附上附件以供参考

谢谢朋友的再次相助啊

chxw68

修改好了。

chxw68

修改好了。

未忘初心

1. Sub Test2()
   
2.     Dim iRow%, iCol%, arr(), i%, j%
   
3.     Application.ScreenUpdating = False
   
4.     iRow = Range("A1").CurrentRegion.Rows.Count - 3
   
5.     iCol = Range("A1").CurrentRegion.Columns.Count
   
6.     If Range("A5").Text = "" Then
   
7.         ReDim arr(1 To iRow / 2, 1 To iCol)
   
8.         For i = 1 To iRow
   
9.             For j = 1 To UBound(arr, 2)
   
10.                 If (3 + i) Mod 2 = 0 Then
    
11.                     arr((i + 1) / 2, j) = Cells(3 + i, j) & Chr(10) & Cells(3 + i + 1, j)
    
12.                 End If
    
13.             Next
    
14.         Next
    
15.     Else
    
16.         ReDim arr(1 To iRow * 2, 1 To iCol)
    
17.         For i = 1 To iRow * 2
    
18.             For j = 1 To UBound(arr, 2)
    
19.                 If i Mod 2 = 0 Then
    
20.                     arr(i, j) = Split(Cells(3 + i / 2, j) & Chr(10), Chr(10))(1)
    
21.                 Else
    
22.                     arr(i, j) = Split(Cells(3 + (i + 1) / 2, j) & Chr(10), Chr(10))(0)
    
23.                 End If
    
24.             Next
    
25.         Next
    
26.     End If
    
27.     Range("A4").Resize(iRow, iCol).Clear
    
28.     Range("A4").Resize(UBound(arr), iCol) = arr
    
29.     Application.ScreenUpdating = True
    
30. End Sub

复制代码