自定义Excel宏DeleteOldData在不同文件中日期读取异常

我在Excel中创建了名为DeleteOldData的宏，用于加速单个文件内多个数据表的数据编辑，功能是根据D3单元格指定的日期删除旧数据。该宏在创建时所在的原Excel文件中运行正常，但将其保存为.xlam加载项文件后，在其他工作表中运行时，读取到的指定日期变为默认的12:00 AM。例如当指定日期为4/25/2023时，调试输出为：

Start date entered: 12:00:00 AM

仅原文件可正常运行，其他文件无法读取正确日期。我怀疑问题与文件类型有关，当时是从工作簿位置而非VBA编辑器窗口保存（VBA编辑器无.xlam选项）。请问该问题的原因是什么？如何解决才能在其他工作表中正常使用该加载项？

原代码如下：

Sub DeleteOldData()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim startDate As Date
    Dim lastRow As Long
    Dim rng As Range
    Dim firstStartDate As Date
    Dim updatedWorksheets As String
    
    ' Set the workbook object to the current workbook
    Set wb = ThisWorkbook
    
    ' Get the start date from the first worksheet
    firstStartDate = wb.Worksheets(1).Range("D3").Value
    
    ' Loop through all the worksheets in the workbook
    For Each ws In wb.Worksheets
        startDate = firstStartDate
        Debug.Print "Start date entered: " & startDate
            
        ' Find the first row with a date greater than or equal to the start date
        Set rng = ws.Columns("A:A").Find(What:=startDate, LookAt:=xlPart, MatchCase:=True)
        ' If the start date is not found, exit the sub
        If rng Is Nothing Then
            MsgBox "Start date not found in Timestamp column"
            Exit Sub
        End If
            
        ' Find the last row of data
        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            
        ' Delete rows from the first row up to but not including the start date row
        If rng.Row > 2 And rng.Row <= lastRow Then 'skip the header row and make sure it's not the last row
            ws.Range("A2:C" & rng.Row - 1).Delete Shift:=xlUp 'Delete only columns A-C and shift remaining cells up
        End If
            
        ' Shift the remaining data up
        ws.Range("A2:C" & lastRow - rng.Row + 1).Cut Destination:=ws.Range("A2")
            
        ' Autofit the columns to adjust for the new data
        ws.Columns("A:C").AutoFit
        
        ' Add the name of the updated worksheet to the list
        updatedWorksheets = updatedWorksheets & ws.Name & ", "
    
    Next ws
    ' Display a message box listing the updated worksheets
    If Len(updatedWorksheets) > 0 Then
        updatedWorksheets = Left(updatedWorksheets, Len(updatedWorksheets) - 2) ' Remove the last comma and space
        MsgBox "Data updated successfully on the following worksheets: " & updatedWorksheets & "!"
    Else
        MsgBox "No worksheets were updated."
    End If
End Sub

核心问题出在ThisWorkbook的引用逻辑上：

• 宏在原工作簿运行时，ThisWorkbook指向包含宏的原工作簿，也就是你输入日期的文件，因此能正确读取D3单元格的日期。
• 宏保存为.xlam加载项后，ThisWorkbook指向的是加载项文件本身，而非你当前操作的目标工作簿。加载项文件的D3单元格为空，所以读取到日期类型的默认值12:00 AM。

你提到的保存方式（从工作簿窗口而非VBA编辑器保存）不是核心问题，只是格式选择的操作路径差异，不影响加载项功能。

将ThisWorkbook替换为ActiveWorkbook，让加载项读取当前激活的目标工作簿的D3单元格，同时增加必要的校验避免出错。

修改后的代码如下：

Sub DeleteOldData()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim startDate As Date
    Dim lastRow As Long
    Dim rng As Range
    Dim firstStartDate As Variant ' 改用Variant类型，避免空值强制转日期出错
    Dim updatedWorksheets As String
    
    ' 校验是否有激活的工作簿
    If ActiveWorkbook Is Nothing Then
        MsgBox "请先打开需要处理的工作簿！"
        Exit Sub
    End If
    
    ' 指向当前激活的工作簿（即用户正在操作的文件）
    Set wb = ActiveWorkbook
    
    ' 获取D3的值，先判断是否为有效日期
    firstStartDate = wb.Worksheets(1).Range("D3").Value
    If Not IsDate(firstStartDate) Then
        MsgBox "D3单元格不是有效日期，请检查！"
        Exit Sub
    End If
    startDate = CDate(firstStartDate)
    
    ' 遍历当前工作簿的所有工作表
    For Each ws In wb.Worksheets
        Debug.Print "Start date entered: " & startDate
            
        ' 改用精确匹配查找日期，避免部分匹配导致的错误
        Set rng = ws.Columns("A:A").Find(What:=startDate, LookAt:=xlWhole, MatchCase:=False, LookIn:=xlValues)
        ' 未找到日期时，提示后跳过当前工作表，而非直接退出宏
        If rng Is Nothing Then
            MsgBox ws.Name & "工作表的时间戳列未找到指定日期，跳过该表！"
            GoTo NextSheet
        End If
            
        ' 获取数据最后一行
        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            
        ' 删除起始日期之前的行（跳过表头）
        If rng.Row > 2 And rng.Row <= lastRow Then
            ws.Range("A2:C" & rng.Row - 1).Delete Shift:=xlUp
        End If
            
        ' 删除行后数据已自动上移，移除多余的剪切操作
        ' ws.Range("A2:C" & lastRow - rng.Row + 1).Cut Destination:=ws.Range("A2")
            
        ' 自动调整列宽
        ws.Columns("A:C").AutoFit
        
        ' 记录已处理的工作表名称
        updatedWorksheets = updatedWorksheets & ws.Name & ", "
    
NextSheet:
    Next ws
    
    ' 显示处理结果
    If Len(updatedWorksheets) > 0 Then
        updatedWorksheets = Left(updatedWorksheets, Len(updatedWorksheets) - 2)
        MsgBox "数据更新完成，已处理工作表：" & updatedWorksheets & "！"
    Else
        MsgBox "没有工作表被更新。"
    End If
End Sub

额外优化说明 #

• 新增激活工作簿校验，防止加载项在无打开文件时运行出错。
• 改用Variant类型接收D3的值，先校验是否为有效日期，避免空值或非日期内容导致的报错。
• 修改Find方法为精确匹配（xlWhole），并指定读取单元格值（LookIn:=xlValues），提升查找准确性。
• 移除多余的剪切操作，避免删除行后重复移动数据导致混乱。
• 未找到日期时改为跳过当前工作表，而非直接退出宏，提升兼容性。

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