求助按总课表分班级学科导出任课教师

zhengqiyu · 发表于 2023-12-12 14:29

zhengqiyu 发表于 2023-12-12 14:27
明白了。谢谢

我以为可以自动识别

3190496160 · 发表于 2023-12-12 14:40

zhengqiyu 发表于 2023-12-12 14:29
我以为可以自动识别

要自动识别也不是不可以，事先也没说呀
另外，究竟如何错位，要有个具体的说明

zhengqiyu · 发表于 2023-12-12 17:57

3190496160 发表于 2023-12-12 14:40
要自动识别也不是不可以，事先也没说呀
另外，究竟如何错位，要有个具体的说明

没有错位，是不同科目，本来就是相同的人哈，能自动识别科目最好哈，应该字典就可以吧

3190496160 · 发表于 2023-12-13 08:13

Sub 提取()
Application.ScreenUpdating = False
Dim br As Variant
Dim ar()
Dim i As Long, r As Long, rs As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("全部班级")
rs = .Cells(Rows.Count, 4).End(xlUp).Row
ys = .Cells(4, Columns.Count).End(xlToLeft).Column + 1
br = .Range(.Cells(4, 2), .Cells(rs, ys))
End With
ReDim ar(1 To UBound(br, 2), 1 To 50)
ar(1, 1) = "班级"
With Sheets("班级学科汇总")
r = .Cells(Rows.Count, 1).End(xlUp).Row
y = .Cells(1, Columns.Count).End(xlToLeft).Column
If r > 1 Then .Range(.Cells(1, 1), .Cells(r, y)).Borders.LineStyle = 0: .Range(.Cells(1, 1), .Cells(r, y)) = ""
y = 1: k = 1
For j = 5 To UBound(br, 2)
      If br(1, j) = "" Then br(1, j) = br(1, j - 1)
      t = d(br(1, j))
      If t = "" Then
         k = k + 1
         d(br(1, j)) = k
         t = k
         ar(k, 1) = br(1, j)
      End If
      For i = 3 To UBound(br)
         If Trim(br(i, j)) <> "" Then
            If InStr(br(i, j), Chr(10)) > 0 Then
                  km = Split(br(i, j), Chr(10))(0)
                  lh = d(km)
                  If lh = "" Then
                     y = y + 1
                     d(km) = y
                     lh = y
                     ar(1, y) = km
                  End If
                  xm = Split(br(i, j), Chr(10))(1)
                  ar(t, lh) = xm
            End If
         End If
      Next i
Next j
.[a1].Resize(k, y) = ar
.[a1].Resize(k, y).Borders.LineStyle = 1
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160 · 发表于 2023-12-13 08:14

科目可以自动生成了

总课表.rar (238.95 KB, 下载次数: 1)

leeson7502 · 发表于 2023-12-13 09:27

试一试看：

Sub reArrange()
Dim ws As Worksheet
Dim lastRow As Integer, lastCol As Integer
Dim arr(), arrStr() As String, arrtemp()
Dim dic As Object
Dim dicSubject As Object '存所有课程
Dim dKey1$, dKey2$, teacher As String
Set dic = CreateObject("Scripting.Dictionary")
Set dicSubject = CreateObject("Scripting.Dictionary")
Set ws = Sheet1
With ws
lastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
lastCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
arr = .Range(.Cells(4, 6), .Cells(lastRow, lastCol))
End With
k = 1
For i = 1 To UBound(arr, 2)
If arr(1, i) <> "" Then
ReDim Preserve arrtemp(k)
arrtemp(k) = arr(1, i)
k = k + 1
End If
Next
For i = 1 To UBound(arr, 2)
If arr(1, i) <> "" Then
dKey1 = arr(1, i)
End If
For j = 2 To UBound(arr)
If arr(j, i) <> "" Then
arrStr = Split(arr(j, i), Chr(10))
If UBound(arrStr) > 0 Then
dKey2 = arrStr(0)
teacher = arrStr(1)
Else
dKey2 = arrStr(0)
teacher = ""
End If
dicSubject(dKey2) = 1
If Not dic.exists(dKey1) Then
dic.Add dKey1, CreateObject("Scripting.Dictionary")
End If
If Not dic(dKey1).exists(dKey2) Then
dic(dKey1).Add dKey2, teacher
End If
End If
Next
Next
arrtemp = Application.WorksheetFunction.Transpose(arrtemp)
ReDim Preserve arrtemp(1 To UBound(arrtemp), 1 To dicSubject.Count + 1)
k = 1
For Each Key In dicSubject.keys
k = k + 1
arrtemp(1, k) = Key
Next
For i = 2 To UBound(arrtemp)
For j = 2 To UBound(arrtemp, 2)
arrtemp(i, j) = dic(arrtemp(i, 1))(arrtemp(1, j))
Next
Next
Set ws = Sheet2
With ws
.Cells.Clear
.Cells(1, 1).Resize(UBound(arrtemp), UBound(arrtemp, 2)) = arrtemp
.Cells(1, 1) = "班级"
End With
MsgBox "Done!"
ws.Activate
ws.Range("A1").Select
End Sub

复制代码

leeson7502 · 发表于 2023-12-13 09:32

参与一下：

kingc138 · 发表于 2024-4-21 00:12

用水晶排课啊！很好用

		自动登录	找回密码
密码			免费注册

求助 按总课表分班级学科导出任课教师

求助按总课表分班级学科导出任课教师