[已解决]教师任课表转换

dyzx

各位老师：请问如何将表1格式转换成表2格式，请多多指教。

最佳答案

月排行榜 / 总排行榜

grf1973

2016-11-24 15:39

把 张生76        初二1—4音乐  初一10、11 初三1—5音乐 舞蹈队
改为  张生76        初二1—4音乐  初一10、11音乐

1. Sub 转换()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Sheets(1).[a1].CurrentRegion
   
4.     For i = 3 To UBound(arr)
   
5.         For j = 2 To UBound(arr, 2) Step 3
   
6.             xm = arr(i, j)   '姓名
   
7.             If Len(xm) > 0 Then
   
8.                 rk = arr(i, j + 1)  '任课
   
9.                 If InStr(rk, "初") > 0 Then
   
10.                     rkrr = Split(rk, " ")
    
11.                     For Each rk In rkrr
    
12.                         If InStr(rk, "初") > 0 And InStr(rk, "任") = 0 Then   '去掉“班任”等
    
13.                             nj = Left(rk, 2) '年级
    
14.                             bj = Mid(rk, 3) '班级+任课
    
15.                             For k = Len(bj) To 1 Step -1
    
16.                                 If IsNumeric(Mid(bj, k, 1)) Then Exit For
    
17.                             Next
    
18.                             km = Mid(bj, k + 1)  '任课
    
19.                             bj = Replace(bj, km, "")   '班级
    
20.                             If Len(bj) = 0 Then bj = "1—20"
    
21.                             p = InStr(bj, "—")
    
22.                             If p > 0 Then    '班级中含“—”，1—5 转换成1、2、3、4、5
    
23.                                 s = Val(bj): e = Val(Mid(bj, p + 1))
    
24.                                 bj = ""
    
25.                                 For k = s To e
    
26.                                     bj = bj & "、" & k
    
27.                                 Next
    
28.                                 bj = Mid(bj, 2)
    
29.                             End If
    
30.                             bjrr = Split(bj, "、")
    
31.                             For k = 0 To UBound(bjrr)
    
32.                                 x = nj & "（" & bjrr(k) & "）班" & km   '年级+班级+任课为key
    
33.                                 d(x) = xm
    
34.                             Next
    
35.                         End If
    
36.                     Next
    
37.                 End If
    
38.             End If
    
39.         Next
    
40.     Next
    
41.     With Sheets(2)
    
42.         .[b3:o100] = ""
    
43.         arr = .[a1].CurrentRegion
    
44.         For i = 3 To UBound(arr)
    
45.             For j = 2 To UBound(arr, 2)
    
46.                 x = arr(i, 1) & arr(2, j)
    
47.                 arr(i, j) = d(x)
    
48.             Next
    
49.         Next
    
50.         .[a1].CurrentRegion = arr
    
51.     End With
    
52. End Sub

复制代码

初三1—5音乐 舞蹈队

跳转到最佳答案楼层

today0427

“分管工作与任课”那一格内容很多，既关联班级，还关联课程，还关联兼任职务，班级名称输入方式也不规范，数据种类混杂，格式太随意，代码很难区分，建议以后规范数据，便于用代码解决

dyzx

today0427 发表于 2016-11-23 15:34
“分管工作与任课”那一格内容很多，既关联班级，还关联课程，还关联兼任职务，班级名称输入方式也不规范， ...

oday0427老师：这样可以转换吗？

today0427

抱歉 我水平有限转换不了 等待学习老师们的方法！

望帝春心

today0427 发表于 2016-11-23 18:24
抱歉 我水平有限转换不了 等待学习老师们的方法！

堵路妈，咱两一起堵着路等大神过来偷学哇

望帝春心

today0427 发表于 2016-11-23 18:24
抱歉 我水平有限转换不了 等待学习老师们的方法！

堵路妈，咱两一起堵着路等大神过来偷学哇

today0427

望帝春心 发表于 2016-11-23 18:37
堵路妈，咱两一起堵着路等大神过来偷学哇

春哥你且坐等 这点宽度我上足矣！[em01]

望帝春心

today0427 发表于 2016-11-23 18:39
春哥你且坐等 这点宽度我上足矣！

刚才是不是你把宽带堵住了，一卡我发出去两条一样的

today0427

一不小心堵路堵出新高度，堵住了信息高速路！[em04]咱俩快别毁人帖了[em15]

grf1973

1. Sub 转换()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Sheets(1).[a1].CurrentRegion
   
4.     For i = 3 To UBound(arr)
   
5.         For j = 2 To UBound(arr, 2) Step 3
   
6.             xm = arr(i, j)   '姓名
   
7.             If Len(xm) > 0 Then
   
8.                 rk = arr(i, j + 1)  '任课
   
9.                 p = InStrRev(rk, "任"): rk = Mid(rk, p + 1)   '去掉“班任”等
   
10.                 p = InStr(rk, "初")
    
11.                 If p > 0 Then
    
12.                     rk = Split(Mid(rk, p), " ")(0)   '年级+班级+任课
    
13.                     nj = Left(rk, 2) '年级
    
14.                     bj = Mid(rk, 3) '班级+任课
    
15.                     For k = Len(bj) To 1 Step -1
    
16.                         If IsNumeric(Mid(bj, k, 1)) Then Exit For
    
17.                     Next
    
18.                     km = Mid(bj, k + 1)  '任课
    
19.                     bj = Replace(bj, km, "")   '班级
    
20.                     If Len(bj) = 0 Then bj = "1—11"
    
21.                     p = InStr(bj, "—")
    
22.                     If p > 0 Then    '班级中含“—”，1—5 转换成1、2、3、4、5
    
23.                         s = Val(bj): e = Val(Mid(bj, p + 1))
    
24.                         bj = ""
    
25.                         For k = s To e
    
26.                             bj = bj & "、" & k
    
27.                         Next
    
28.                         bj = Mid(bj, 2)
    
29.                     End If
    
30.                     bjrr = Split(bj, "、")
    
31.                     For k = 0 To UBound(bjrr)
    
32.                         x = nj & "（" & bjrr(k) & "）班" & km   '年级+班级+任课为key
    
33.                         d(x) = xm
    
34.                     Next
    
35.                 End If
    
36.             End If
    
37.         Next
    
38.     Next
    
39.     With Sheets(2)
    
40.         .[b3:o100] = ""
    
41.         arr = .[a1].CurrentRegion
    
42.         For i = 3 To UBound(arr)
    
43.             For j = 2 To UBound(arr, 2)
    
44.                 x = arr(i, 1) & arr(2, j)
    
45.                 arr(i, j) = d(x)
    
46.             Next
    
47.         Next
    
48.         .[a1].CurrentRegion = arr
    
49.     End With
    
50. End Sub

复制代码