Search code examples
excelvba

Add rows whenever an ID has no record for that day

I have a "pessoas" worksheet with a table that links IDs with names.

I have a data "outquery" worksheet with a table that contains these columns:

ID Name (formula) Date Entry time Exit time
3 Marco Polo 07/02/2024 08:42:00.000 15:21:00.000

In that same data worksheet I have a table which contains all the weekdays for that month ("DiasTrabalho").

I want to add rows between existing records whenever an ID has no record for each date. As it stands, I only have data created by entries and exits, if that ID does not record an entry, no data is generated.

I made the following code.

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

It replaces a few of the top rows of the data table with blank spaces, and creates a new column as well.
Error Print
Error Print

Solution

  • Here's one approach to try

    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

    Assuming you're on Windows and have access to scripting.dictionary