Вычтите оставшийся час из дня с помощью VBA

У меня есть код ниже, который будет определять значения воскресенья и выделения в Col M, если они больше 1, и текст «ждет» в столбце P.

Я хочу сделать следующее:

  1. У меня есть формат даты и времени в MM / D / YYYY TIME (пример) – 1/22/2017 23:30
  2. Я хочу вычесть воскресное время даты с сокращением времени 23:59, и оставшееся число должно быть вычтено со значением в col M, и если все же значение больше, чем col M, тогда оно должно быть выделено красным.

Пример сценария:

Если дата / время составляет 1/22/2017 21:00 в col K, то оставшийся час здесь составляет 0,3 часа. Это следует вычесть из значения в col M, допустим, что col M имеет 1,3, поэтому 1.3-0.3 = 1. Поэтому он должен быть выделен.

Результат выборки: Образец вывода

Код:

Sub SundayDatefilter() Dim r, lastrow, remainingDay As Long lastrow = Range("M:P").Cells(Rows.count, "A").End(xlUp).Row Application.ScreenUpdating = False For r = 2 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 Application.ScreenUpdating = True End Sub 

Как я уже упоминал в своем комментарии, просто измените тип данных elseDay, поскольку Long является целым типом (без десятичной части).

 Sub SundayDatefilter() Dim r, lastrow, remainingDay As Double '<--- Correction lastrow = Range("M:P").Cells(Rows.Count, "A").End(xlUp).Row Application.ScreenUpdating = False For r = 2 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 '<--- Correction Range("M" & r).Cells.Font.ColorIndex = 3 Else Range("M" & r).Cells.Font.ColorIndex = 0 End If End If End If Next r Application.ScreenUpdating = True End Sub 
Interesting Posts

Условное форматирование или макрос включен – изменение цвета фона ячейки на основе другого значения ячейки

Exel VBA: ошибка времени выполнения 13 Несоответствие типа

Почему при запуске сразу нескольких сотен VBS-файлов, только около 50 или около того

Не закрывайте excel.exe, когда открываете его oledb C #

Как вы читаете защищенный паролем файл excel в r?

Копирование данных между двумя книгами с использованием нескольких критериев

Добавление изображений и текста в исходную игру Excel

Выйдите из цикла «Для каждого», когда выполняется определенное условие

как добавить формулу в столбец, содержит значения

Макрос заполняет неправильные значения – текущая дата

Почему однобайтовое имя UDF не использует C или R?

Создал excel, но не смог открыть с помощью rssheet

Линии разрыва Excel не передаются в TextBox

Автоматическое увеличение в vb.net

Как читать значение ячейки, которая указывает другие ячейки листа?

Давайте будем гением компьютера.