Интересные и полезные статьи по работе с Excel и VBA
можно найти в разделе ХИТРОСТИ

Sub CollectGreenDates_AllDates_NoFilter_FontColor()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim curDate As Variant
Dim dictDateStatus As Object ' дата -> True (все зелёные) или False (есть не-зелёное)
Dim cellB As Range
Dim greenFontRGB As Long
Dim redFontRGB As Long
Dim greensDates As Object ' список дат
Dim key As Variant
Dim msg As String
Dim colI As String
Set ws = ThisWorkbook.Sheets(1) ' замените на ваш лист
lastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
colI = "I"
' Задайте конкретные RGB-значения для зелёного и красного шрифта
greenFontRGB = RGB(0, 255, 0) ' зеленый замените на ваш - здесь можно задавать вариации зеленого и крансого цветов
redFontRGB = RGB(255, 0, 0) ' красный; замените на ваш
Set dictDateStatus = CreateObject("Scripting.Dictionary")
dictDateStatus.CompareMode = vbTextCompare
' Сбор статуса по каждой дате
For i = 2 To lastRow ' предполагаем заголовок в строке 1
If Not IsEmpty(ws.Cells(i, colI).Value) Then
curDate = ws.Cells(i, colI).Value
Set cellB = ws.Cells(i, "B")
If IsDate(curDate) Then
Dim fColor As Long
fColor = cellB.Font.Color
If fColor = greenFontRGB Then
If Not dictDateStatus.Exists(curDate) Then
dictDateStatus(curDate) = True
Else
dictDateStatus(curDate) = dictDateStatus(curDate) And True
End If
ElseIf fColor = redFontRGB Then
dictDateStatus(curDate) = False
Else
dictDateStatus(curDate) = False
End If
End If
End If
Next i
' Собираем даты, где статус True (все зелёные)
Set greensDates = CreateObject("System.Collections.ArrayList")
For Each key In dictDateStatus.Keys
If dictDateStatus(key) = True Then
greensDates.Add key
End If
Next key
' Вывод
If greensDates.Count > 0 Then
msg = "Зелёные даты:" & vbCrLf
For Each key In greensDates
If IsDate(key) Then
msg = msg & Format(CDate(key), "yyyy-mm-dd") & vbCrLf
Else
msg = msg & key & vbCrLf
End If
Next key
Else
msg = "Дат с полностью зелёными значениями в столбце B нет."
End If
MsgBox msg, vbInformation
End Sub
Sub GetDateColor()
Dim ws As Worksheet
Dim dicDates As Object
Dim llastr&, lr&, lcolor&
Dim dt As Date
Dim s$, scolor$
Set ws = ActiveSheet
Set dicDates = CreateObject("Scripting.Dictionary")
dicDates.comparemode = 1
With ws
llastr = .Cells(.Rows.Count, "I").End(xlUp).Row
For lr = 2 To llastr
dt = .Cells(lr, 9).Value
lcolor = .Cells(lr, 2).Font.Color
If dt > 0 Then
Select Case lcolor
Case 255 'red
scolor = "красный"
Case 5287936 'green
scolor = "зеленый"
End Select
If Not dicDates.Exists(dt) Then
dicDates.Add dt, scolor
Else
If dicDates.Item(dt) <> scolor Then
dicDates.Item(dt) = "двойственная"
End If
End If
End If
Next
End With
If dicDates.Count Then
ws.Range("O2").Resize(dicDates.Count, 1).Value = Application.Transpose(dicDates.keys)
ws.Range("N2").Resize(dicDates.Count, 1).Value = Application.Transpose(dicDates.items)
End If
End Sub
Буду благодарна, если найдете минутку посмотреть. Файл приложила.
Т.к. судя по описанию код не выглядит сложным.If allGreen ThenЦитата: Vladislav10 от 09.12.2025, 14:21:50Я бы понял, и не такое понималину да, ну да
