Search code examples
excelvbapivot-table

Excel - exctract "zeros" data - Small modification

I would like to add small modification to [previous question].

How can I add a condition to the main body of the code to skip cells with 'zero' that have a colored background?

When checking cells, the modification should ignore those that have any background color (marked in red), and only take into account those that have no background formatting (marked in blue).

Example:

enter image description here

My code looks now like this:

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
Solution

    • Add an If statement to check whether the fill color of the cell is vbWhite.

    • rngData begins from B4, so there are row and column offsets to obtain the cell reference.

    If arrData(i, j) = 0 And Not IsEmpty(arrData(i, j)) Then
    If wsOB.Cells(i + 3, j + 1).Interior.Color = vbWhite Then
        iR = iR + 1
        arrRes(iR, 0) = arrData(i, 2) & "-" & arrData(i, 1) & "-" & Format(arrData(2, j), "dd.mm.yyyy")
    End If
End If