能转换成个人的课表吗？能看得见他在哪个班上课就行，高二徐莹莹和赵秀兼职带安全课。

廖月

xbox1210 发表于 2024-11-24 11:00
那加两句试试

徐莹莹不可能同在这么多班上课

xbox1210

廖月 发表于 2024-11-24 14:32
徐莹莹不可能同在这么多班上课

好的，总体思路没问题。再加上一句判断。一个字典搞定。

翁知江安

Sub zhuanhuan()
Dim irow, icolumn, i, j, k, irow1, icolumn1, m, n, irow2, icolumn2, s, t, ss, y, tt, mm, p
Dim arr, brr, crr
Dim d1, d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
irow = Sheets("人事").[a65336].End(xlUp).Row
icolumn = Sheets("人事").[iv2].End(xlToLeft).Column
arr = Sheets("人事").[a1].Resize(irow, icolumn)
For i = 3 To irow
    For j = 2 To icolumn
    d1(arr(i, 1) & arr(2, j)) = arr(i, j)
Next
Next
irow1 = Sheets("课表").[a65336].End(xlUp).Row
icolumn1 = Sheets("课表").[iv3].End(xlToLeft).Column
brr = Sheets("课表").[a1].Resize(irow1, icolumn1)
mm = (icolumn1 - 1) / 12
For m = 4 To irow1
  For n = 1 To mm
     For s = 2 + (n - 1) * 12 To 12 * n + 1
     If brr(m, s) <> 0 And brr(m, s) <> "" Then
     p = d1(brr(m, 1) & brr(m, s))
     d2(brr(2, 12 * n - 10) & brr(3, s) & p & brr(m, s)) = brr(m, 1)
     End If
     Next
  Next
Next
irow2 = Sheets("转换").[a65336].End(xlUp).Row
icolumn2 = Sheets("转换").[iv2].End(xlToLeft).Column
ReDim crr(1 To irow2 - 2, 1 To icolumn2 - 2)
ss = (icolumn2 - 2) / 12
For tt = 3 To irow2
    For t = 1 To ss
      For y = 3 + (t - 1) * 12 To 12 * t + 2
      crr(tt - 2, y - 2) = d2(Sheets("转换").Cells(1, 3 + (t - 1) * 12).Value & Sheets("转换").Cells(2, y).Value & Sheets("转换").Cells(tt, 1).Value & Sheets("转换").Cells(tt, 2).Value)
      Next
    Next
Next
Sheets("转换").Cells(3, 3).Resize(UBound(crr), UBound(crr, 2)) = crr
MsgBox "ok"
End Sub

翁知江安

供参考，欢迎批评指正

廖月

xbox1210 发表于 2024-11-24 17:58
好的，总体思路没问题。再加上一句判断。一个字典搞定。

老师，昨天那个问题解决了，又出现新问题，徐莹莹和赵秀她俩都兼职带安全课，赵秀安全课看得见，怎么徐莹莹只有四班的课，看不见他在其他班达安全课呢？

廖月

翁知江安 发表于 2024-11-24 22:30
供参考，欢迎批评指正

徐莹莹和赵秀兼职问题没解决，第1节和第10.11节同时带多个班问题没解决