老师帮忙看看代码，判断出来时间前后都差1分钟

一把小刀闯天下

tengyt 发表于 2018-7-4 12:43
上面代码在上表运行很好，谢谢老师

我插入两列后，你帮我写的代码不能运行了，我还做了列调整

'规则是否有问题，跟你的示例结果相差很多。

'代码按你规则来写的看不出有什么毛病，自己好好确认一下。

Option Explicit

Sub test()
  Dim mark, i, t, arr, a, b
  arr = Range("l2:o2" & Cells(Rows.Count, "l").End(xlUp).Row)
  mark = "一二三四五六日"
  For i = 1 To UBound(arr, 1)
    If arr(i, 1) = #12:00:00 AM# Then
      arr(i, 1) = "无考勤记录"
    Else
      t = InStr(mark, Right(arr(i, 3), 1))
      Select Case t
      Case 1: a = #9:00:00 AM#: b = #10:00:00 AM#
      Case 2 To 4, 6, 7
        If arr(i, 4) = "上午" Then
          a = #9:00:00 AM#: b = #10:00:00 AM#
        Else
          a = #2:30:00 PM#: b = #3:30:00 PM#
        End If
      Case 5: a = #3:30:00 PM#: b = #5:00:00 PM#
      End Select
      arr(i, 1) = IIf(CDate(arr(i, 1)) >= a And CDate(arr(i, 1)) <= b, "按时", "未按时")
    End If
  Next
  [s2].Resize(UBound(arr, 1)) = arr  '把s2 改成m2就可以，这里做比较用
End Sub

tengyt

一把小刀闯天下 发表于 2018-7-4 13:23
'规则是否有问题，跟你的示例结果相差很多。

'代码按你规则来写的看不出有什么毛病，自己好好确认一下。 ...

老师，辛苦了，谢谢你了
运行很好，就是底下会多出很多“无考勤记录”，删除起来麻烦
还想增加一个，例如临时决定“2015/3/3”、“2015/3/11”只要签到时间“06:00:00--18:00:00”有签到，都算“按时”，能不能再帮忙预留两行代码，以便以后方便随时添加使用，再次感谢老师，老师，您辛苦了

tengyt

一把小刀闯天下 发表于 2018-7-4 13:23
'规则是否有问题，跟你的示例结果相差很多。

'代码按你规则来写的看不出有什么毛病，自己好好确认一下。 ...

老师，辛苦了，谢谢你了
运行很好，就是底下会多出很多“无考勤记录”，删除起来麻烦
还想增加一个，例如临时决定“2015/3/3”、“2015/3/11”只要签到时间“06:00:00--18:00:00”有签到，都算“按时”，能不能再帮忙预留两行代码，以便以后方便随时添加使用，再次感谢老师，老师，您辛苦了

一把小刀闯天下

tengyt 发表于 2018-7-4 18:49
老师，辛苦了，谢谢你了
运行很好，就是底下会多出很多“无考勤记录”，删除起来麻烦
还想增加一个，例 ...

'可在[q2]、[q3]分别写入2015/3/3、2015/3/11 (就是例外处理,个数不限但为连续单元格)

'"多出很多"，是你工作表的问题。已加条件避免出现这情况

Option Explicit

Sub test()
  Dim mark, i, t, arr, a, b, dic
  Set dic = CreateObject("scripting.dictionary")
  If IsDate([q2]) Then '例外：[q2]开始，向下连续，行数不限
    For i = 2 To Cells(Rows.Count, "q").End(xlUp).Row
     If Not IsDate(Cells(i, "q")) Then Exit For
     dic(CStr(Cells(i, "q"))) = vbNullString
    Next
  End If
  arr = Range("k2:o2" & Cells(Rows.Count, "b").End(xlUp).Row)
  mark = "一二三四五六日"
  For i = 1 To UBound(arr, 1)
    If dic.exists(CStr(arr(i, 1))) Then '例外处理
      arr(i, 1) = IIf(CDate(arr(i, 2)) >= #6:00:00 AM# _
        And CDate(arr(i, 2)) <= #6:00:00 PM#, "按时", "未按时")
    Else
      If arr(i, 2) = #12:00:00 AM# Then
        If Len(arr(i, 2)) > 0 Then arr(i, 1) = "无考勤记录"
      Else
        t = InStr(mark, Right(arr(i, 4), 1))
        Select Case t
        Case 1: a = #9:00:00 AM#: b = #10:00:00 AM#
        Case 2 To 4, 6, 7
          If arr(i, 5) = "上午" Then
            a = #9:00:00 AM#: b = #10:00:00 AM#
          Else
            a = #2:30:00 PM#: b = #3:30:00 PM#
          End If
        Case 5: a = #3:30:00 PM#: b = #5:00:00 PM#
        End Select
        arr(i, 1) = IIf(CDate(arr(i, 2)) >= a And _
          CDate(arr(i, 2)) <= b, "按时", "未按时")
      End If
    End If
  Next
  [m2].Resize(UBound(arr, 1)) = arr
End Sub

tengyt

一把小刀闯天下 发表于 2018-7-5 08:30
'可在[q2]、[q3]分别写入2015/3/3、2015/3/11 (就是例外处理,个数不限但为连续单元格)

'"多出很多"， ...

太完美了，太强大了，辛苦了老师，谢谢你了，稍后一定评分

tengyt

一把小刀闯天下 发表于 2018-7-5 08:30
'可在[q2]、[q3]分别写入2015/3/3、2015/3/11 (就是例外处理,个数不限但为连续单元格)

'"多出很多"， ...

老师再帮忙写个，表格都一样一天签4次，周一到周日都是以下时间
8:00-8:10    11:20-11:30    14:00-14:10    17:00-17:30

上面代码再帮忙改改，辛苦老师了，万分感谢

一把小刀闯天下

tengyt 发表于 2018-7-5 16:48
老师再帮忙写个，表格都一样一天签4次，周一到周日都是以下时间
8:00-8:10    11:20-11:30    14:00-14: ...

'按12楼的附件瞎掰的，因为条件太少也没有示例，先写个

'可以再上个附件然后做些简要说明，当然最好得有示例图

Option Explicit

Sub test()
  Dim arr, tm, i, j
  arr = Range("k2:o2" & Cells(Rows.Count, "b").End(xlUp).Row)
  tm = Array(#8:00:00 AM#, #8:10:00 AM#, #11:20:00 AM#, #11:30:00 AM#, # _
    2:00:00 PM#, #2:10:00 PM#, #5:00:00 PM#, #5:30:00 PM#)
  For i = 1 To UBound(arr, 1)
    If Len(arr(i, 2)) = 0 Then Exit For
    For j = 0 To UBound(tm) Step 2
      If CDate(arr(i, 2)) >= tm(j) And CDate(arr(i, 2)) <= tm(j + 1) Then Exit For
    Next
    arr(i, 1) = IIf(j = UBound(tm) + 1, "异常", "按时")
  Next
  [m2].Resize(UBound(arr, 1)) = arr
End Sub

tengyt

压缩文件里面讲的较详细

老师，先谢谢了，帮忙再写写代码
1.行政人员签到增加“00:00:00”显示“无考勤记录”
2.行政人员签到增加，例如临时决定“2015-03-03”、“2015-03-12”只要签到时间范围“06:00:00--18:00:00”有签到，都算“按时”，帮忙预留写两行代码，以便以后方便随时添加使用，再次感谢老师

tengyt

一把小刀闯天下 发表于 2018-7-5 19:23
'按12楼的附件瞎掰的，因为条件太少也没有示例，先写个

'可以再上个附件然后做些简要说明，当然最好得 ...

压缩文件里面讲的较详细

老师，先谢谢了，帮忙再写写代码
1.行政人员签到增加“00:00:00”显示“无考勤记录”
2.行政人员签到增加，例如临时决定“2015-03-03”、“2015-03-12”只要签到时间范围“06:00:00--18:00:00”有签到，都算“按时”，帮忙预留写两行代码，以便以后方便随时添加使用，再次感谢老师

一把小刀闯天下

tengyt 发表于 2018-7-5 21:14
压缩文件里面讲的较详细

老师，先谢谢了，帮忙再写写代码

'拼在一起了，应该差不多，自己好好测试一下

Option Explicit

Sub 行政人员签到()
  Dim arr, tm, i, j, dic
  Set dic = CreateObject("scripting.dictionary")
  If IsDate([v2]) Then '例外条件
    For i = 2 To Cells(Rows.Count, "v").End(xlUp).Row
     If Not IsDate(Cells(i, "v")) Then Exit For
     dic(CStr(Cells(i, "v"))) = vbNullString
    Next
  End If
  arr = Range("k2:o2" & Cells(Rows.Count, "b").End(xlUp).Row)
  tm = Array(#8:00:00 AM#, #8:10:00 AM#, #11:20:00 AM#, #11:30:00 AM# _
    , #2:00:00 PM#, #2:10:00 PM#, #5:00:00 PM#, #5:30:00 PM#)
  For i = 1 To UBound(arr, 1)
    If dic.exists(CStr(arr(i, 1))) Then '例外处理
      arr(i, 1) = IIf(CDate(arr(i, 2)) >= #6:00:00 AM# And _
        CDate(arr(i, 2)) <= #6:00:00 PM#, "按时", "无考勤记录")
    Else
      If arr(i, 2) = #12:00:00 AM# Then '处理#00:00:00#
        If Len(arr(i, 2)) > 0 Then arr(i, 1) = "无考勤记录"
      Else
        For j = 0 To UBound(tm) Step 2
          If CDate(arr(i, 2)) >= tm(j) And CDate(arr(i, 2)) <= tm(j + 1) Then Exit For
        Next
        arr(i, 1) = IIf(j = UBound(tm) + 1, "异常", "按时")
      End If
    End If
  Next
  [m2].Resize(UBound(arr, 1)) = arr
End Sub