Excel - extraer datos "ceros" - Pequeña modificación

Me gustaría agregar una pequeña modificación a [pregunta anterior] .

¿Cómo puedo agregar una condición al cuerpo principal del código para omitir celdas con 'cero' que tienen un fondo de color?

Al verificar las celdas, la modificación debe ignorar aquellas que tienen algún color de fondo (marcadas en rojo) y solo tener en cuenta aquellas que no tienen formato de fondo (marcadas en azul).

Ejemplo:

Mi código ahora se ve así:

Option Explicit

Sub OB_Raport_brakow()
Dim i As Long, j As Long
Dim arrData As Variant
Dim rngData As Range
Dim arrRes, iR As Long
Dim LastRow As Long, wsOB As Worksheet
Dim DataRange As Range

' Sprawdza jaka jest ostatnia linia tabeli przestawnej
LastRow = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Set wsOB = Sheets("OB")

' Określa zakres komorek do sprawdzenia
' zakres półautomatyczny - początek na sztywno, a koniec na ostatni rząd tabeli przestawnej +1
' by ostatnie "zero" nie uciekało z raportu

' Set rngData = wsOB.Range("B4:R" & LastRow + 1)


    ' Deklaruj zmienną do przechowywania wyboru użytkownika
    Dim strCol As String
    

    ' Pyta jaka kolumna będzie ogranicznikiem do sprawdzania braków
    
    strCol = InputBox("Podaj kolumnę, do której mają zostać pobrane dane:", "Wybór kolumny")

    ' Ustaw rngData na zakres danych
    Set rngData = wsOB.Range("B4:" & strCol & LastRow + 1)


arrData = rngData.Value
ReDim arrRes(1 To UBound(arrData) * 31, 0)
iR = 0

For j = LBound(arrData, 2) + 2 To UBound(arrData, 2)
    If arrData(4, j) = "T" Then
        For i = LBound(arrData) + 4 To UBound(arrData)
            If arrData(i, j) = 0 And Not IsEmpty(arrData(i, j)) Then
                iR = iR + 1
                arrRes(iR, 0) = arrData(i, 2) & "-" & arrData(i, 1) & "-" & Format(arrData(2, j), "dd.mm.yyyy")
                
            End If
        Next
    End If
Next

On Error GoTo Catch
Try:
'Próbuje wybrać arkusz o wskaznej nazwie
    Sheets("OB Rp").Select
    GoTo Finally
Catch:
'Jeśli focus na wskazany arkusz się nie uda to tworzy go
    Sheets.Add(After:=Sheets("OB")).Name = "OB Rp"
Finally:
On Error GoTo 0

'Aktywuje arkusz do raportu, czyści go a następnie uzupełnia danymi
Sheets("OB Rp").Activate
'Cells.Clear
Range("B1:D600").ClearContents
Range("B1:B" & iR).Value = arrRes

'Rodziela na kolumny B i C, to co znajduje się w kolumnie A za pomocą separatora "-"
'Dim arrTmp() As String
'For i = 1 To iR
'    arrTmp = Split(arrRes(i, 0), "-")
'    Range("A" & i).Value = arrTmp(0)
'    Range("B" & i).Value = arrTmp(1)
'    Range("C" & i).Value = arrTmp(2)
'Next

'Na koniec sortuje A-Z według kolumny z nazwiskiem
Range("B1").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlYes

End Sub

Feb 16 '24 13:02 KMYozz