基于星期与时间补全Excel Master表缺失行的VBA实现问题

问题根源 #

原代码未将星期+startTime作为联合匹配键，仅单独校验startTime，导致跨星期插入了不属于当前日期对应星期的时间（比如给周四插入周日专属的505时间）。

修正后的VBA代码 #

Sub FillMissingTimeRows()
    Dim eventDict As Object
    Set eventDict = CreateObject("Scripting.Dictionary")
    
    ' 加载EventLists表的星期-时间映射
    Dim wsEvent As Worksheet
    Set wsEvent = ThisWorkbook.Worksheets("EventLists")
    Dim lastRowEvent As Long
    lastRowEvent = wsEvent.Cells(wsEvent.Rows.Count, "A").End(xlUp).Row
    
    Dim i As Long
    For i = 2 To lastRowEvent ' 跳过表头行
        Dim weekVal As String
        weekVal = wsEvent.Cells(i, "A").Value
        Dim timeVal As String
        timeVal = wsEvent.Cells(i, "C").Value
        
        ' 按星期分组存储对应时间集合
        If Not eventDict.Exists(weekVal) Then
            Set eventDict(weekVal) = CreateObject("Scripting.Dictionary")
        End If
        eventDict(weekVal)(timeVal) = True
    Next i
    
    ' 收集Master表中每个日期已有的时间
    Dim dateTimeDict As Object
    Set dateTimeDict = CreateObject("Scripting.Dictionary")
    
    Dim wsMaster As Worksheet
    Set wsMaster = ThisWorkbook.Worksheets("Master")
    Dim lastRowMaster As Long
    lastRowMaster = wsMaster.Cells(wsMaster.Rows.Count, "A").End(xlUp).Row
    
    Dim j As Long
    For j = 2 To lastRowMaster ' 跳过表头行
        Dim dtKey As Date
        dtKey = wsMaster.Cells(j, "A").Value
        Dim tmKey As String
        tmKey = wsMaster.Cells(j, "C").Value
        
        If Not dateTimeDict.Exists(dtKey) Then
            Set dateTimeDict(dtKey) = CreateObject("Scripting.Dictionary")
        End If
        dateTimeDict(dtKey)(tmKey) = True
    Next j
    
    ' 遍历每个日期，检查并插入缺失的时间行
    Dim dt As Variant
    For Each dt In dateTimeDict.Keys
        Dim weekStr As String
        ' 将日期转换为与EventLists一致的星期文本（需和你的表中格式匹配）
        Select Case Weekday(dt, vbMonday)
            Case 1: weekStr = "周一"
            Case 2: weekStr = "周二"
            Case 3: weekStr = "周三"
            Case 4: weekStr = "周四"
            Case 5: weekStr = "周五"
            Case 6: weekStr = "周六"
            Case 7: weekStr = "周日"
        End Select
        
        ' 仅处理EventLists中存在的星期
        If eventDict.Exists(weekStr) Then
            Dim tm As Variant
            For Each tm In eventDict(weekStr).Keys
                ' 若当前日期无该时间，插入行
                If Not dateTimeDict(dt).Exists(tm) Then
                    ' 找到该日期的最后一行位置，保证插入后仍按时间升序排列
                    Dim insertRow As Long
                    insertRow = wsMaster.Cells(wsMaster.Rows.Count, "A").Find(What:=dt, LookIn:=xlValues, LookAt:=xlWhole).Row
                    Do While wsMaster.Cells(insertRow + 1, "A").Value = dt
                        insertRow = insertRow + 1
                    Loop
                    insertRow = insertRow + 1
                    
                    ' 插入新行并填充数据
                    wsMaster.Rows(insertRow).Insert Shift:=xlDown
                    wsMaster.Cells(insertRow, "A").Value = dt
                    wsMaster.Cells(insertRow, "B").Value = weekStr ' 若B列存星期，按需调整
                    wsMaster.Cells(insertRow, "C").Value = tm
                    wsMaster.Cells(insertRow, "D").Value = "ADD" ' 若Type列不是D，需修改列号
                    
                    ' 复制上一行格式（可选）
                    wsMaster.Rows(insertRow - 1).Copy
                    wsMaster.Rows(insertRow).PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End If
            Next tm
        End If
    Next dt
End Sub

关键修改说明 #

1. 联合键映射：将EventLists的数据按星期分组存储，每个星期对应专属的startTime集合，彻底避免跨星期匹配错误。
2. 日期时间预收集：先把Master表中每个日期已有的时间存为字典，快速判断缺失项，提升处理效率。
3. 精准插入位置：找到对应日期的最后一行时间，插入到其后，保证Master表始终保持「日期+时间」的升序排列。
4. 星期格式匹配：通过Weekday函数将日期转换为与EventLists完全一致的星期文本（如“周一”），确保匹配键无偏差。

注意事项 #

• 若你的表格表头不在第一行、列号与代码假设不符，需对应调整循环起始行和列索引。
• 确保EventLists中的星期文本（如“周日”）与代码中Select Case的输出完全一致，否则会匹配失败。

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