VBA实现多条件日期匹配填充：基于案件编号提取≥今日的日期

原代码问题分析 #

你的代码无报错但无法提取数据，核心原因是直接通过行号匹配两张表的行，但两张表的案件编号（A列）并不一定在同一行，导致无法正确关联对应的数据。

修正后的代码 #

Sub LookUpBlankDatesSA()
    Dim wsOpenCases As Worksheet
    Dim wsSADates As Worksheet
    Dim lastRowOpen As Long
    Dim lastRowSA As Long
    Dim i As Long
    Dim caseDict As Object
    
    ' 初始化字典用于存储案件编号与符合条件的日期映射
    Set caseDict = CreateObject("Scripting.Dictionary")
    
    ' 关联目标工作表
    Set wsOpenCases = ThisWorkbook.Sheets("OpenCasesSummary")
    Set wsSADates = ThisWorkbook.Sheets("SA Dates")
    
    ' 获取SA Dates表A列最后一行数据行号
    lastRowSA = wsSADates.Cells(wsSADates.Rows.Count, "A").End(xlUp).Row
    
    ' 预处理SA Dates表，将≥今日的日期与案件编号存入字典
    For i = 2 To lastRowSA ' 假设SA Dates表头在第1行，数据从第2行开始
        Dim caseID As Variant
        Dim saDate As Date
        caseID = wsSADates.Cells(i, "A").Value
        saDate = wsSADates.Cells(i, "B").Value
        
        ' 仅存入符合日期条件且未记录过的案件编号（重复案件保留最后一个符合条件的日期）
        If saDate >= Date And Not caseDict.Exists(caseID) Then
            caseDict.Add caseID, saDate
        End If
    Next i
    
    ' 获取OpenCasesSummary表J列最后一行数据行号
    lastRowOpen = wsOpenCases.Cells(wsOpenCases.Rows.Count, "J").End(xlUp).Row
    
    ' 遍历OpenCasesSummary表，填充空的J列单元格
    For i = 4 To lastRowOpen
        If IsEmpty(wsOpenCases.Cells(i, "J").Value) Then
            caseID = wsOpenCases.Cells(i, "A").Value
            ' 通过案件编号在字典中查找对应日期
            If caseDict.Exists(caseID) Then
                wsOpenCases.Cells(i, "J").Value = caseDict(caseID)
            End If
        End If
    Next i
    
    ' 释放对象，避免内存占用
    Set caseDict = Nothing
    Set wsOpenCases = Nothing
    Set wsSADates = Nothing
End Sub

关键改进说明 #

• 用字典实现精准关联：通过Scripting.Dictionary建立案件编号与日期的映射关系，彻底解决两张表行号不匹配的问题，查找效率远高于逐行比对
• 预处理过滤数据：提前筛选SA Dates中≥今日的日期，避免后续重复判断，提升代码运行效率
• 针对性填充：仅对OpenCasesSummary中J列空单元格进行处理，保留手动输入的内容不被覆盖
• 内存优化：代码末尾释放所有对象变量，避免长期运行导致的内存泄漏

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