根据即时时间，删除A列对应的整行

jsfc

根据即时时间，删除A列对应的整行：
1、周一：
   即时时间在15:00前，A列中“前天”、“昨天”、“今天”对应的整行数据保留，其他的删除
   即时时间在15:00后，A列中对应“明天”的整行数据保留，其他的删除
2、周二至周五：
   即时时间在15:00前，A列中对应“今天”的整行数据保留，其他的删除
   即时时间在15:00后，A列中对应“明天”的整行数据保留，其他的删除
3、周六：
   不考虑即时时间，A列中对应“今天”、“明天”的整行数据保留，其他的删除
4、周日：
   不考虑即时时间，A列中对应“昨天”、“今天”、“明天”的整行数据保留，其他的删除

weare2

试一试！！！！！！！！

jsfc

weare2 发表于 2019-9-26 15:33
试一试！！！！！！！！

谢谢，目前测试正常

jsfc

weare2 发表于 2019-9-26 15:33
试一试！！！！！！！！

周五15:00前测试，结果是：需要反复点按钮，逐条删除不是今天的行，最终才显示“今天”的行数据
15：00后结果显示正常

jsfc

weare2 发表于 2019-9-26 15:33
试一试！！！！！！！！

周六15:00前和15:00后测试，结果：全部正确显示
周日15:00前和15:00后测试，结果是：只显示"今天”和"明天"，“昨天”的数据不显示

jsfc

weare2 发表于 2019-9-26 15:33
试一试！！！！！！！！

周一15:00前测试结果：“前天”、“昨天”、“今天”对应的整行数据全部被删除了

weare2

Sub e()
Dim rn As Range, rns As Range
On Error GoTo 100
    Select Case Weekday(Now, 2)
        Case Is = 1 '周一
        If Time < CDate("15:00:00") Then
            For Each rn In Range("a2:a" & Cells(Rows.Count, "a").End(3).Row)
                 y = rn.Value
                If Date - 2 < rn.Value < Date Then
                    n = n + 1
                    If n = 1 Then
                        Set rns = rn.EntireRow.Range("a1:e1")
                    Else
                        Set rns = Union(rns, rn.EntireRow.Range("a1:e1"))
                    End If
                    rns.Delete
                End If
            Next
        Else
             For Each rn In Range("a2:a" & Cells(Rows.Count, "a").End(3).Row)
                If rn.Value <> Date + 1 Then
                    n = n + 1
                    If n = 1 Then
                        Set rns = rn.EntireRow.Range("a1:e1")
                    Else
                        Set rns = Union(rns, rn.EntireRow.Range("a1:e1"))
                    End If
                End If
            Next
        rns.Delete
        End If
   
    '周六
        Case Is = 6
            For Each rn In Range("a2:a" & Cells(Rows.Count, "a").End(3).Row)
               If rn <> Date + 1 And rn <> Date Then
                    n = n + 1
                    If n = 1 Then
                        Set rns = rn.EntireRow.Range("a1:e1")
                    Else
                        Set rns = Union(rns, rn.EntireRow.Range("a1:e1"))
                    End If
               End If
            Next
            rns.Delete
    '周日
        Case Is = 7
          For Each rn In Range("a2:a" & Cells(Rows.Count, "a").End(3).Row)
               If rn <> Date + 1 And rn <> Date And rn <> Date Then
                    n = n + 1
                    If n = 1 Then
                        Set rns = rn.EntireRow.Range("a1:e1")
                    Else
                        Set rns = Union(rns, rn.EntireRow.Range("a1:e1"))
                    End If
               End If
          Next
         rns.Delete
            
     '周2-5
        Case Is > 1
        If Time < CDate("15:00:00") Then
            For Each rn In Range("a2:a" & Cells(Rows.Count, "a").End(3).Row)
                If rn.Value <> Date Then
                    n = n + 1
                    If n = 1 Then
                        Set rns = rn.EntireRow.Range("a1:e1")
                    Else
                        Set rns = Union(rns, rn.EntireRow.Range("a1:e1"))
                    End If
                End If
            Next
             rns.Delete
        Else
             For Each rn In Range("a2:a" & Cells(Rows.Count, "a").End(3).Row)
                If rn.Value <> Date + 1 Then
                    n = n + 1
                    If n = 1 Then
                        Set rns = rn.EntireRow.Range("a1:e1")
                    Else
                        Set rns = Union(rns, rn.EntireRow.Range("a1:e1"))
                    End If
                End If
            Next
        rns.Delete
        End If
    End Select
100
End Sub

把这个放进去了对了

jsfc

weare2 发表于 2019-10-3 12:56
Sub e()
Dim rn As Range, rns As Range
On Error GoTo 100

测试了一段时间，周日15:00前和15:00后测试，结果还是：只显示"今天”和"明天"，“昨天”的数据不显示