Excel VBA补全缺失日期记录时出现数据覆盖与列异常

我有一个名为pessoas的工作表，里面是ID与姓名的关联表格。还有一个outquery数据工作表，包含以下列：

在outquery工作表里还有一个DiasTrabalho表格，存着当月所有工作日。我想给每个ID补全缺失日期的记录行：现在只有员工打卡生成的数据，没打卡就没有对应记录。我写了下面的VBA代码，但运行后出问题了：数据表格顶部部分行被空白覆盖，还生成了额外的错误列。

错误截图：

原代码：

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

代码问题分析 #

1. 查找逻辑错误：用cellId & cellDate拼接字符串查找，但ID和日期是分两列存储的，根本找不到匹配项，导致错误添加大量行。
2. 新增行方式错误：dataRange.Find("*", ...)会定位到数据区域的第一个单元格，直接赋值会覆盖原有数据，这就是顶部行被空白覆盖的原因。
3. 未定义变量：代码中使用了ws但未声明赋值，会触发运行错误。
4. 破坏表格结构：直接操作单元格新增行，没有使用ListObject的官方方法，导致表格结构混乱，出现错误列。

修正后的代码 #

Sub AddMissingLines()
    Dim outQueryTbl As ListObject
    Dim pessoasTbl As ListObject
    Dim diasTrabalhoTbl As ListObject
    Dim idCell As Range
    Dim dateCell As Range
    Dim foundId As Range
    Dim foundDate As Range
    Dim newRow As ListRow
    Dim matchFound As Boolean
    
    ' 关闭屏幕更新和自动计算提升效率
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 绑定表格对象，避免依赖ActiveSheet
    Set outQueryTbl = ThisWorkbook.Worksheets("outquery").ListObjects("outquery")
    Set pessoasTbl = ThisWorkbook.Worksheets("Pessoas").ListObjects("pessoas")
    Set diasTrabalhoTbl = ThisWorkbook.Worksheets("outquery").ListObjects("DiasTrabalho")
    
    ' 遍历所有员工ID
    For Each idCell In pessoasTbl.ListColumns(1).DataBodyRange
        ' 遍历所有工作日
        For Each dateCell In diasTrabalhoTbl.ListColumns(1).DataBodyRange
            matchFound = False
            ' 查找当前ID是否存在记录
            Set foundId = outQueryTbl.ListColumns("ID").DataBodyRange.Find( _
                What:=idCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
            
            If Not foundId Is Nothing Then
                ' 在ID的记录范围内查找对应日期
                Set foundDate = outQueryTbl.ListColumns("日期").DataBodyRange.Find( _
                    What:=dateCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                
                ' 检查是否是同一行的ID+日期组合
                Do While Not foundDate Is Nothing
                    If foundDate.Row = foundId.Row Then
                        matchFound = True
                        Exit Do
                    End If
                    Set foundDate = outQueryTbl.ListColumns("日期").DataBodyRange.FindNext(foundDate)
                Loop
            End If
            
            ' 无匹配记录则新增行
            If Not matchFound Then
                Set newRow = outQueryTbl.ListRows.Add(AlwaysInsert:=True)
                newRow.Range(1).Value = idCell.Value ' 赋值ID
                newRow.Range(3).Value = dateCell.Value ' 赋值日期
                ' 姓名列由公式自动生成，上班/下班时间留空
                newRow.Range(4).Value = ""
                newRow.Range(5).Value = ""
            End If
        Next dateCell
    Next idCell
    
    ' 恢复屏幕更新和自动计算
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

修正说明 #

• 绑定表格对象：直接指定工作表和表格，避免依赖ActiveSheet，减少运行错误。
• 正确匹配记录：分别查找ID和对应日期，确保是同一行的ID+日期组合，避免拼接字符串的错误逻辑。
• 规范新增行：使用ListRows.Add方法新增表格行，不会破坏原有表格结构，避免错误列出现。
• 保留公式列：姓名列由公式生成，无需手动赋值，仅填充ID、日期，其他列留空即可。

内容的提问来源于stack exchange，提问作者Diogo Oliveira