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

[IrKa]

Добрый день всем уважаемым форумчанам!
Буду благодарна за помощь с написанием макроса.
Задача: есть таблица Excel. В столбце "I" - даты (они повторяются) В столбце "B" - числа двух цветов: красные и зеленые.
Что хочу получить: сортируем по какой-то дате и, если для этой даты в столбце "B" только зеленые числа, то
в столбце "N" пишем "зеленая", в столбце "O" пишем эту дату. То есть, задача выбрать только те даты, для которых числа в столбце "В" зеленые.
Я загнала задачу ИИ, он мне написал код, но ничего не выводится. Я начала разбираться, в целом код понятный, хоть я вообще не знаю, как писать код))) Но пыталась вчера разобраться, так как очень надо для работы. И получается, что все корректно работает (я ставила в код сообщения вывода, чтобы понять, на каком месте всё обламывается), но код, выделенный красным почему-то не выполняется.
Подскажите, пожалуйста, в чем дело!

Sub CheckCellColorsByDate()
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(1)
    If ws Is Nothing Then
        MsgBox "Лист '2026' не найден. Проверьте название листа."
        Exit Sub
    End If
    On Error GoTo 0
   
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
    MsgBox "Последняя строка: " & lastRow
   
    Dim uniqueDates As Object
    Set uniqueDates = CreateObject("Scripting.Dictionary")
   
    Dim i As Long
    ' Собираем уникальные даты
    For i = 2 To lastRow
        Dim dt As Variant
        dt = ws.Cells(i, "I").Value
        If Not IsEmpty(dt) Then
            If Not uniqueDates.Exists(dt) Then
                uniqueDates.Add dt, True
            End If
        End If
    Next i
   
    MsgBox "Найдено уникальных дат: " & uniqueDates.Count ' Здесь работает, кол-во уникальных дат выводит
   

   
    Dim dateKey As Variant
    For Each dateKey In uniqueDates.Keys
        Dim allGreen As Boolean
        allGreen = True
        ' Проверяем все строки с этой датой
        For i = 2 To lastRow
            If ws.Cells(i, "I").Value = dateKey Then
                Dim cellColor As Long
                cellColor = ws.Cells(i, "B").Interior.Color
                ' Проверка на зеленый цвет (RGB)
                If cellColor <> vbGreen Then
                    allGreen = False
                      'MsgBox "ОНО НЕ ЗЕЛЕНОЕ!!!!!!"  '- ЭТА ПРОВЕРКА РАБОТАЕТ - СООБЩЕНИЕ ВЫВОДИТСЯ RGB(0, 255, 0)
                    Exit For
                End If
            End If
        Next i
        ' Записываем результат
        If allGreen Then
        'MsgBox "НАШЕЛ ЗЕЛЕНУЮ ДАТУ!!!!!!"
            For i = 2 To lastRow
                If CStr(ws.Cells(i, "I").Value) = CStr(dateKey) Then
                    ws.Cells(i, "N").Value = "зеленый"
                    ws.Cells(i, "O").Value = dateKey
                End If
            Next i
         End If
         
    Next dateKey
   
    MsgBox "Обработка завершена."
End Sub

 

[Дмитрий Щербаков(The_Prist)]

Так все правильно - если выводит сообщение, что ячейка не зеленая - то allGreen будет False и соответственно этот блок будет пропущен:

Код Выделить Развернуть

If allGreen Then

[IrKa]

Дмитрий, спасибо, что откликнулись!
Я поняла уже, что макрос вообще не корректный, не выполняет свою задачу(
А сколько у Вас стоит написать макрос под мою задачу?

[Дмитрий Щербаков(The_Prist)]

Вы бы приложили файл с данными и описали бы задачу применительно к нему. Здесь, на форуме. Глядишь и бесплатно ответ получите Т.к. судя по описанию код не выглядит сложным.

[IrKa]

Дмитрий, спасибо!   Буду благодарна, если найдете минутку посмотреть. Файл приложила.
Задача:
В столбце "I" - даты (они повторяются). В столбце "B" - числа двух цветов: красные и зеленые.
Что хочу получить:
Фильтруем по какой-то дате и, если для этой даты в столбце "B" только зеленые числа, то
в столбце "N" пишем "зеленая", в столбце "O" пишем эту дату.
Если для какой-то даты в столбце "B" только красные числа, то в столбце "N" пишем "красная", в столбце "O" пишем эту дату.
Если для какой-то даты в столбце "B" числа разного цвета (и зеленые, и красные), то в столбце "N" пишем "двойственная", в столбце "O" пишем эту дату.
То есть, мне в итоге нужно получить такую таблицу: "дата-цвет" (Я в файле написала пример, как это должно выглядеть).

[Дмитрий Щербаков(The_Prist)]

Код Выделить Развернуть

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

[IrKa]

Дмитрий, спасибо Вам большое!
У меня тут у самой (ну, не без помощи ИИ, конечно))) тоже получилось выводить массив из зеленых дат.

Код Выделить Развернуть

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