Extract "zeros" data as "Name + date" from Pivot Table, using 1 row element and 2 column elements

Question

I searched but didn't find anything interesting. I enlisted ChatGPT.

• In the "OB" sheet I have a pivot table that is named "OBEC_ALL".
• In the columns of this table I have the following data: "date" and "prc?", where for the date I have e.g. "2023.12.06" and for "prc?" I have "T" or "N" (yes/no)
• In the lines I have "code" data, e.g. 101, 203, 305 etc. and "employee" e.g. "JOHN DOE".
• The results of the pivot table include numbers showing the number of events ("Event") for a person on a given day. If there is no event, then zero "0" is inserted (in the table settings, zero is inserted in empty fields).

I would like to:

• create a new sheet "test" after the "OB" workbook
• in the next rows of this sheet write the "rule" if the value field has zero and at the same time in this column "prc?" has the value "T"
• this rule is e.g. Emily Johnson - 2023.12.04 and below is another one for a different date where the value is 0 and "prc?" has a "T"

The essence is to write out line by line the "employee + date" pairs for which there are no events in the database on a given day to be able to report and complete them.

Sub WypiszZeroweZdarzenia()
    Dim wsOB As Worksheet
    Dim wsTest As Worksheet
    Dim pivotTable As PivotTable
    Dim dataRange As Range
    Dim cell As Range
    Dim pracownik As String
    Dim data As Date
    Dim isZero As Boolean
    Dim prcValue As Variant
    
    ' Ustaw arkusz "OB" jako aktywny
    Set wsOB = Sheets("OB")
    wsOB.Activate
    
    ' Ustaw pivot table
    Set pivotTable = wsOB.PivotTables("OBEC_ALL")
    
    ' Ustaw zakres danych dla pola "Zdarz"
    Set dataRange = pivotTable.DataBodyRange
    
    ' Sprawdź, czy arkusz "test" już istnieje
    On Error Resume Next
    Set wsTest = Worksheets("test")
    On Error GoTo 0
    
    ' Jeżeli arkusz "test" nie istnieje, utwórz nowy zaraz za arkuszem "OB"
    If wsTest Is Nothing Then
        Set wsTest = Sheets.Add(After:=wsOB)
        wsTest.Name = "test"
    Else
        ' Jeżeli istnieje, wyczyść zawartość od komórki A1 w dół
        wsTest.Cells.Clear
    End If
    
    ' Dla każdej komórki w zakresie danych
    For Each cell In dataRange
        ' Sprawdź, czy wartość w komórce to 0
        If cell.Value = 0 Then
            ' Pobierz pracownika i datę
            pracownik = cell.RowFields(2).Name
            data = cell.ColumnFields(1).Name
            
            ' Sprawdź wartość "prc?" dla danej daty
            prcValue = cell.ColumnFields(2).Name
            
            ' Ustaw flagę na true tylko jeżeli "prc?" to "T"
            isZero = (prcValue = "T")
            
            ' Sprawdź kolejne komórki w wierszu, aby uniknąć powtórzeń dla tego samego pracownika
            For Each cellInRow In cell.RowRange
                If cellInRow.Value = 0 Then
                    ' Jeżeli kolejna komórka w wierszu również ma wartość 0, to ustaw flagę na false
                    isZero = False
                    Exit For
                End If
            Next cellInRow
            
            ' Jeżeli flaga jest nadal true, to wpisz dane do arkusza "test"
            If isZero Then
                wsTest.Cells(wsTest.Cells(wsTest.Rows.Count, "A").End(xlUp).Row + 1, 1).Value = pracownik & " - " & Format(data, "yyyy.mm.dd")
            End If
        End If
    Next cell
End Sub

Error 438 appears.

Debug shows:

pracownik = cell.RowFields(2).Name

Answer 1

• GPT makes the code more complicated than it should be.
• Load pivot table into an array, then extract data
• Write output into sheet all at once

Option Explicit

Sub Demo()
    Dim i As Long, j As Long
    Dim arrData, rngData As Range
    Dim arrRes, iR As Long
    Dim LastRow As Long, wsOB As Worksheet
    Set wsOB = Sheets("OB")
    Set rngData = wsOB.PivotTables("OBEC_ALL").TableRange1
'    Set rngData = wsOB.Range("B4:AH12") ' for testing
    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 Then
                    iR = iR + 1
                    arrRes(iR, 0) = arrData(i, 2) & " - " & Format(arrData(2, j), "yyyy.mm.dd")
                End If
            Next
        End If
    Next
    Sheets.Add
    Range("A1:A" & iR).Value = arrRes
End Sub

The first ten cells in output sheet

Emily Johnson - 2023.12.04
Emily Johnson - 2023.12.05
Emily Johnson - 2023.12.06
Michael Davis - 2023.12.06
Emily Johnson - 2023.12.07
Michael Davis - 2023.12.07
Emily Johnson - 2023.12.08
Michael Davis - 2023.12.08
Emily Johnson - 2023.12.11
Michael Davis - 2023.12.11

Please apply Repeat All Item Lable on pivottable first.

Then it's easy to get kod.

arrRes(iR, 0) = arrData(i, 1) & " - " & arrData(i, 2) & " - " & Format(arrData(2, j), "yyyy.mm.dd")