想想莲莲 发表于 2021-10-14 21:26:00

如何在总课表中提取个人课表（与中小学完全不一样））

提取个人课表：例如要填写苏行大佬的星期一第1节课，就去星期一第1节的所有课中去找，找到含有苏行大佬的课，提取这节课的班级名字、这节课的名称，然后用班级和这节课的名称中间用1个空格隔开组成苏行大佬的星期一第1节课。如果苏行大佬的星期一第1节课没有课，则此处显示为空值。自习也同理。





                                       

浮游星辰 发表于 2021-10-31 21:08:56

王小窝 发表于 2021-11-4 06:03:32

做了一部分是不是这效果？

郝志光 发表于 2021-11-28 09:38:06

Sub 个人课表()
Dim m, s, i, j, x, k, t, arr, brr, crr(1 To 5, 1 To 9), sa
Dim d As Object, dx As Object
Set d = CreateObject("scripting.dictionary")
Set dx = CreateObject("scripting.dictionary")
sa = Array("一", "二", "三", "四", "五")
Sheet2.Range("C4:K8") = ""
For i = 0 To 4
dx(sa(i)) = i + 1
Next
arr = Sheet1.Range("A1").CurrentRegion
For i = 2 To UBound(arr)
For j = 4 To UBound(arr, 2)
   If Len(arr(i, j)) > 2 Then
   s = Right(arr(i, j), 2)
   If Not d.exists(s) Then
      m = 1
      ReDim brr(1 To 3, 1 To m)
      Else
      brr = d(s)
      m = UBound(brr, 2) + 1
      ReDim Preserve brr(1 To 3, 1 To m)
      End If
      brr(1, m) = dx(arr(i, 1))
      brr(2, m) = j - 3
      brr(3, m) = arr(i, 2) & " " & Trim(Mid(arr(i, j), 1, Len(arr(i, j)) - 2))
      d(s) = brr
    End If
Next
Next
k = d.keys
t = d.items
a = Sheet2.Range("K2")
For x = 0 To d.Count - 1
If k(x) = a Then
    For i = 1 To UBound(t(x), 2)
      crr(t(x)(1, i), t(x)(2, i)) = t(x)(3, i)
    Next
End If
Next
Sheet2.Range("C4").Resize(5, 9) = crr
Set d = Nothing
Set dx = Nothing
End Sub

长林胖鱼哭坟祖宗 发表于 2021-12-5 06:31:22

看一看，对不对？

家居世界 发表于 2021-12-11 21:45:16

谢谢你了，试了一下，中。以后还得多学习才中。

贺元 发表于 2022-1-15 15:47:11

谢谢你！尽管对vba还不是很熟悉，以后慢慢学习。
页: [1]
查看完整版本: 如何在总课表中提取个人课表（与中小学完全不一样））