Excel - 使用 1 行元素和 2 列元素从数据透视表中提取“零”数据作为“名称 + 日期”

Question

在我在这里问问题之前，我决定在互联网上进行一些搜索，但我没有发现任何有趣的东西。所以我寻求艾的帮助，但陷入了困境。我没有Excel脚本的经验，但我正在努力改进我的工作，因此我渴望解决这个问题。我可以寻求帮助来修复代码吗？

详情：

• 在“OB”表中，我有一个名为“OBEC_ALL”的数据透视表。
• 在此表的列中，我有以下数据：“date”和“prc？”，其中的日期是我的，例如“2023.12.06”和“prc？”我有“T”或“N”（是/否）
• 在这些行中我有“代码”数据，例如101、203、305 等以及“雇员”，例如“约翰·多伊”。
• 数据透视表的结果包括显示某个人在给定日期发生的事件（“事件”）数量的数字。如果没有事件，则插入零“0”（在表设置中，在空字段中插入零）。

我希望脚本能够：

• 在“OB”工作簿之后创建了一个新工作表“test”
• 在该表的下几行中，如果值字段为零，则他写了“规则”，同时在此列“prc？”中写了“规则”。值为“T”
• 这条规则例如Emily Johnson - 2023 年 12 月 04 日及以下是另一个不同日期的日期，其值为 0 且“prc？”有一个“T”

本质就是逐行写出数据库中当天没有事件的“员工+日期”对，以便能够报告和完成。

到目前为止，运行脚本时，出现错误 438，而 ChatGPT 无法修复它，它在各种不起作用的建议之间交替。

谢谢您的帮助。

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

错误“438”后，调试显示行：

pracownik = cell.RowFields(2).Name

Answer 1

• GPT 使代码变得比应有的更复杂。
• 将数据透视表加载到数组中，然后提取数据
• 一次性将输出写入工作表

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 DataRange = 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