|
|
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 |
|
