Question

我在Col K下的日期和时间以及与Col M下的这些天相对应的某些值（数字）。

我有一个代码，如果这些值大于1，并且如果它们在col P中有“等待”文本，则会更改这些值的颜色。

我不知道要做的是，将以下条件添加到此代码中：

1.我想确定这些日子是否属于星期天。

2.如果是，那么我想查看周日时间（假设日期/时间格式为“15/1/2016 17:00”，因此周日剩余的剩余时间为0.3天）从Col M中的数字中减去，如果数字仍为> 1，则应以“红色”突出显示。

3.减法不应影响或出现在当前表格中。

我尝试了下面的代码，但由于没有结果，我不确定我在哪里犯了错误。

Sub Datefilter()
Dim r As Long
Dim m As Long

On Error GoTo ExitHere:
m = Range("M:P").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Application.ScreenUpdating = False
   For r = 1 To m
      remainingDay = 0

       If Weekday(Range("K" & r)) = 1 Then

              remainingDay = Round((24 - Format(TimeValue(Range("K" & r)), "h")) / 24, 1)

               End If
      If Range("P" & r) = "*waiting*" Then
            If Range("M" & r) - remainingDay >= 1 Then
                  Range("M" & r).Cells.Font.ColorIndex = 3
                  Else
                 Range("M" & r).Cells.Font.ColorIndex = 0
               End If
               End If
      Next r
      ExitHere:
      Application.ScreenUpdating = True
End Sub

Answer 1

我觉得使用Excel的内置函数和一些帮助列会更容易。

（1）使用WEEKDAY()功能获取星期几。然后使用简单的比较来检查它是否是星期天。

（2）日期存储为自1900年1月0日以来到期的时间量，部分日期为分数。因此，要返回时间，只需从日期=A1-ROUNDDOWN(A1,0)

中取出日期的圆角位

（3）使用条件格式来检查单元格是否为＆lt; 1然后将其变为红色。

如果您想要一个示例的屏幕截图，请告诉我。

Answer 2

试试这个：

Sub Datefilter()

Dim r, lastrow, remainingDay As Long

'On Error GoTo ExitHere: ' I recommend to delete this

lastrow = Range("M:P").Cells(Rows.Count, "A").End(xlUp).Row

Application.ScreenUpdating = False

   For r = 1 To lastrow
      remainingDay = 0

        If Weekday(Range("K" & r).Value, vbSunday) = 1 Then
                remainingDay = Round((24 - Format(TimeValue(Range("K" & r)), "h")) / 24, 1)

             If InStr(1, Range("P" & r).Text, "waiting", vbTextCompare) > 0 Then

                 If Range("M" & r) - remainingDay >= 1 Then
                     Range("M" & r).Cells.Font.ColorIndex = 3
                 Else
                     Range("M" & r).Cells.Font.ColorIndex = 0
                 End If
             End If
        End If
    Next r
'ExitHere: ' I recommend to delete this
      Application.ScreenUpdating = True
End Sub

根据VBA

2 个答案: