每当 ID 当天没有记录时添加行

Question

我有一个“pessoas”工作表，其中有一个将 ID 与名称链接起来的表格。

我有一个数据“outquery”工作表，其中的表包含这些列：

身份证	名称（式）	日期	入场时间	退出时间
3	马可波罗	2024年7月2日	08:42:00.000	15:21:00.000

在同一个数据工作表中，我有一个表，其中包含该月的所有工作日（“DiasTrabalho”）。

每当 ID 没有每个日期的记录时，我想在现有记录之间添加行。就目前情况而言，我只有入口和出口创建的数据，如果该 ID 没有记录入口，则不会生成数据。

我编写了以下代码。

Sub AddMissingLines()
    Dim dataRange As Range
    Dim idRange As Range
    Dim dateRange As Range
    Dim cellId As Range
    Dim cellDate As Range
    Dim checkRecord As Range
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set dataRange = ActiveSheet.ListObjects("outquery").DataBodyRange
    Set idRange = Worksheets("Pessoas").ListObjects("pessoas").ListColumns(1).DataBodyRange
    Set dateRange = ActiveSheet.ListObjects("DiasTrabalho").ListColumns(1).DataBodyRange
    For Each cellId In idRange
        For Each cellDate In dateRange
            Set checkRecord = dataRange.Find(What:=cellId & cellDate, LookIn:=xlValues)
            If checkRecord Is Nothing Then
                Set newRow = dataRange.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlNext)
                If newRow Is Nothing Then
                    Set newRow = ws.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Offset(1, 0)
                End If
                newRow.Cells(1, 1).Value = cellId.Value
                newRow.Cells(1, 2).Value = cellDate.Value
            End If
        Next cellDate
    Next cellId
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

它用空格替换数据表顶部的一些行，并创建一个新列。
错误打印

Answer 1

这是一种可以尝试的方法

Sub AddMissingLines()
    Dim dict As Object, r As Long, arrOut, loOut As ListObject, ws As Worksheet, k
    Dim id, dt, arrIds, arrDates
    
    Set ws = ActiveSheet
    Set loOut = ws.ListObjects("outquery")
    Set dict = CreateObject("scripting.dictionary")
    
    'get existing table data as 2D arrays
    arrIds = Worksheets("Pessoas").ListObjects("pessoas").ListColumns(1).DataBodyRange.Value
    arrDates = ws.ListObjects("DiasTrabalho").ListColumns(1).DataBodyRange.Value
    arrOut = loOut.DataBodyRange.Value
    
    'collect all unique combinations of id and date from the existing "outquery" rows
    For r = 1 To UBound(arrOut, 1)
        dict(GetKey(arrOut(r, 1), arrOut(r, 3))) = True
    Next r
    
    'now check for rows to be added
    For Each id In arrIds
        For Each dt In arrDates
            k = GetKey(id, dt) 'create key
            If Not dict.Exists(k) Then        'new id+date combination?
                With loOut.ListRows.Add.Range 'add a new ListRow and add values to it
                    .Cells(1).Value = id
                    .Cells(2).Value = dt
                End With
                dict.Add k, True
            End If
        Next dt
    Next id
    
End Sub

'create a composite key from an id and a date
Function GetKey(id, dt)
    GetKey = id & ":" & Format(dt, "yyyy-mm-dd")
End Function

假设您使用的是 Windows 并且可以访问

scripting.dictionary