从总课表里列举出每位大佬课程，做成考勤表

锖

Sub 考勤表()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant, cr As Variant
Dim i As Long
Dim arr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("人事")
  ar = .[a1].CurrentRegion
End With
For i = 3 To UBound(ar)
  If Trim(ar(i, 1)) <> "" Then
  If IsNumeric(ar(i, 1)) Then
    d(ar(i, 1)) = i
  End If
  End If
Next i
For j = 3 To UBound(ar, 2)
  If Trim(ar(2, j)) <> "" Then
  zf = Left(Trim(ar(2, j)), 1)
   d(zf) = j
  End If
Next j
With Sheets("考勤")
r = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("c3:l" & r) = Empty
  br = .Range("a2:l" & r)
  For i = 2 To UBound(br)
  If Trim(br(i, 1)) <> "" Then
    dc(Trim(br(i, 1))) = i
  End If
  Next i
  zc = .[b1].Value
  Set Rng = Sheets("课表").Rows(2).Find(zc, , , , , , 1)
  If Rng Is Nothing Then MsgBox "找不到你设置的周次！": End
  ws = Rng.Column
  rs = Sheets("课表").Cells(Rows.Count, 1).End(xlUp).Row
  cr = Sheets("课表").[a1].CurrentRegion
  For i = 4 To UBound(cr)
  For j = ws To ws + 7
    If Trim(cr(i, j)) <> "" Then
      xh = d(cr(i, 1))
      lh = d(Trim(cr(i, j)))
      If xh <> "" And lh <> "" Then
      xx = ar(xh, lh)
      m = dc(xx)
      If m <> "" Then
        hh = cr(3, j) + 2
        br(m, hh) = cr(i, 1) & "-" & cr(i, j)
      End If
      End If
    End If
  Next j
  Next i
  .Range("a2:l" & r) = br
End With
MsgBox "ok!"
End Sub

独舞淚飛揚

Private Sub Worksheet_Change(ByVal T As Range)
If T.Row = 1 And T.Column = 12 Then
  If T.Value = "" Then End
  Call 考勤表
End If
End Sub

时间诠释一切

从课表里生成考勤表.rar (44.52 KB, 下载次数: 11)

2021-11-7 10:52 上传

点击文件名下载附件
从课表里生成考勤表.rar

祥兴服装杨祥林

求大师帮忙，把这天每位大佬的课程自动填入填入，日期变化，课程也跟着变化，这就做成了考勤表。比如11月7日石珊珊大佬上午四节课，还有许胜宝大佬下午四节，把所有大佬的课都显示出来
从课表里生成考勤表.zip (34.03 KB, 下载次数: 174)

2021-11-7 10:52 上传

点击文件名下载附件
从课表里生成考勤表.zip

黑白一笑

是课程表，对不起，我描述清楚