获取单元格对应数据的问题（cpez）

wwww32323

如图的课程表，想在sheet2得到


或者得到



每一科目对应的班级（一班是1，二班是2，三班是3，。。。，十六班是16），时间（周一是1，周二是2，周三是3。。。），节次（图二中星期一、星期二。。。下边的数字就是节次）

课表问题.rar (7.81 KB, 下载次数: 1)

2019-1-13 08:26 上传

点击文件名下载附件

microyip

1. Sub Result()
   
2.     Dim vData As Variant, nRow As Integer, nCol As Integer, nPart As Integer
   
3.     Dim nWeek As Integer, nClass As Integer, sSubject As String
   
4.     Dim dicClass As Object, dicWeek As Object
   
5.     Dim vFill As Variant, nFill As Integer, nI As Integer
   
6.    
   
7.     Set dicWeek = CreateObject("Scripting.Dictionary")
   
8.     vData = Split("星期一,星期二,星期三,星期四,星期五,星期六,星期日", ",")
   
9.     For nPart = 0 To UBound(vData)
   
10.         dicWeek(vData(nPart)) = nPart + 1
    
11.     Next
    
12. 
    
13.     Set dicClass = CreateObject("Scripting.Dictionary")
    
14.     vData = Split("一,二,三,四,五,六,七,八,九,十,十一,十二,十三,十四,十五,十六,十七,十八,十九,二十", ",")
    
15.     For nPart = 0 To UBound(vData)
    
16.         dicClass(vData(nPart)) = nPart + 1
    
17.     Next
    
18.    
    
19.     ReDim vFill(1 To 4, 1 To 1)
    
20.     vData = Sheets("课程表").UsedRange.Value
    
21.     For nRow = 3 To UBound(vData)
    
22.         If dicClass.Exists(Trim(vData(nRow, 1))) Then
    
23.             nClass = dicClass(Trim(vData(nRow, 1)))
    
24.             For nCol = 2 To UBound(vData,2)
    
25.                 sSubject = Trim(vData(nRow, nCol))
    
26.                 If sSubject <> "" Then
    
27.                     If dicWeek.Exists(Trim(vData(1, nCol))) Then nWeek = dicWeek(Trim(vData(1, nCol)))
    
28.                     nPart = Val(vData(2, nCol))
    
29.                     nFill = nFill + 1
    
30.                     ReDim Preserve vFill(1 To 4, 1 To nFill)
    
31.                     vFill(1, nFill) = sSubject
    
32.                     vFill(2, nFill) = nClass
    
33.                     vFill(3, nFill) = nWeek
    
34.                     vFill(4, nFill) = nPart
    
35.                 End If
    
36.             Next
    
37.         End If
    
38.     Next
    
39.    
    
40.     If nFill > 0 Then
    
41.         Application.ScreenUpdating = False
    
42.         With Sheets("课表结果")
    
43.             .UsedRange.Offset(1).ClearContents
    
44.             .[A2].Resize(nFill, 4) = Application.WorksheetFunction.Transpose(vFill)
    
45.             .[A1].Resize(nFill + 1, 4).Sort Key1:=.[A2], Order1:=xlAscending, Key2:=.[B2], Order2:=xlAscending, Key3:=.[C2], Order3:=xlAscending, Header:=xlGuess
    
46.         End With
    
47.         Application.ScreenUpdating = True
    
48.     End If
    
49. End Sub

复制代码

microyip

附上附件以供参考

wwww32323

microyip 发表于 2019-1-13 09:42
附上附件以供参考

非常感谢。不过美中不足有漏的，取出的数据不完整。比如
语文
1        语        1        1
1        语        2        3
1        语        3        5
1        语        5        7
应该是4行数据  不过还是感谢。我是小白智慧在别人基础上修修补补。我试试能否解决。

microyip

wwww32323 发表于 2019-1-13 10:17
非常感谢。不过美中不足有漏的，取出的数据不完整。比如
语文
1        语        1        1

你是对的，我手贱写漏了个参数

microyip

已经更新代码，重新下载一下吧

wwww32323

microyip 发表于 2019-1-13 12:52
已经更新代码，重新下载一下吧

非常感谢

wwww32323

microyip 发表于 2019-1-13 12:52
已经更新代码，重新下载一下吧

谢谢谢谢谢谢谢谢谢谢谢谢