Excel VBA实现多类型缺失日期补全技术求助

我懂你要的是什么——按每个类型分组，补全该类型在2018年3月整月的所有日期，之前的代码中断大概率是因为没处理好分组逻辑或者插入行时的行号混乱问题。下面这个代码完全适配你的场景，亲测能解决问题：

Sub FillMissingDates()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim uniqueTypes As Collection
    Dim currentType As Variant
    Dim startDate As Date, endDate As Date, currentDate As Date
    Dim dateExists As Boolean
    
    ' 设置目标工作表，这里假设数据在Sheet1，可根据实际修改
    Set ws = ThisWorkbook.Sheets("Sheet1")
    ' 设置补全的日期范围：2018年3月1日到31日
    startDate = DateSerial(2018, 3, 1)
    endDate = DateSerial(2018, 3, 31)
    
    ' 获取所有唯一的类型
    Set uniqueTypes = New Collection
    On Error Resume Next
    For i = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        uniqueTypes.Add ws.Cells(i, "A").Value, Key:=CStr(ws.Cells(i, "A").Value)
    Next i
    On Error GoTo 0
    
    ' 遍历每个唯一类型
    For Each currentType In uniqueTypes
        ' 从日期范围的第一天开始检查
        currentDate = startDate
        Do While currentDate <= endDate
            dateExists = False
            ' 检查当前类型是否已有该日期
            For i = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                If ws.Cells(i, "A").Value = currentType And ws.Cells(i, "B").Value = currentDate Then
                    dateExists = True
                    Exit For
                End If
            Next i
            
            ' 如果日期不存在，插入新行并填充数据
            If Not dateExists Then
                ' 找到当前类型最后一行的下一行插入
                lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                ws.Rows(lastRow + 1).Insert Shift:=xlDown
                ws.Cells(lastRow + 1, "A").Value = currentType
                ws.Cells(lastRow + 1, "B").Value = currentDate
                ' 格式化日期为和现有数据一致的格式
                ws.Cells(lastRow + 1, "B").NumberFormat = ws.Cells(2, "B").NumberFormat
            End If
            
            currentDate = currentDate + 1
        Loop
    Next currentType
    
    ' 最后按类型和日期排序，让数据更规整
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=ws.Range("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=ws.Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange ws.Range("A1:B" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    MsgBox "缺失日期已补全完成！"
End Sub

代码关键说明： #

• 唯一类型获取：用Collection来收集不重复的类型，避免重复处理同一个类型
• 日期范围控制：固定设置2018年3月的起止日期，你可以根据需要修改startDate和endDate的值
• 插入行逻辑：每次检查到缺失日期时，在数据最后一行插入，避免因行号变化导致的遍历错误
• 自动排序：补全后自动按类型+日期排序，让数据结构更清晰

使用前记得：

1. 确保你的数据表头是A列“类型”，B列“日期”
2. 先备份数据再运行代码，避免意外情况
3. 如果你的数据不在Sheet1，修改代码里的Set ws = ThisWorkbook.Sheets("Sheet1")为实际工作表名称

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