使用VBA自动打开文件夹最新月度xlsm文件并解决Object Variable报错

报错原因 #

你遇到的Object Variable or With Block not Set报错核心原因是data_wb工作簿对象未被成功初始化，调用其内部属性时触发空对象错误，具体触发点有两个：

1. 你写的测试版自动找文件逻辑顺序错误：循环内先执行MyFile = Dir取到空值后再尝试打开文件，打开失败后data_wb未被赋值
2. 现有代码没有对文件打开结果、工作表是否存在做校验，一旦文件不存在、打开失败或者目标工作表缺失就会直接报错
   另外你原有自动找文件的逻辑只能遍历所有符合条件的文件，无法识别最新文件，也没有文件不存在时的提示逻辑。

修复后完整代码 #

直接替换你现有全部代码即可，自动实现「当月文件夹找最新FinalPrice开头的xlsm文件，不存在就提示文件过旧」的需求，同时移除了不必要的Select、Activate操作避免报错：

Option Explicit ' 强制变量声明，避免拼写错误
Sub 自动导入数据()
    Dim vDate As Date
    Dim wbMe As Workbook
    Dim data_wb As Workbook
    Dim inputbx As String
    Dim loc As Range, lc As Long, locPaste As Range
    Dim MyFolder As String, ThisMonth As String
    Dim MyFile As String, newestFile As String
    Dim newestDate As Date, fileDate As Date
    Dim DateIsValid As Boolean
    
    ' 初始化当前工作簿
    Set wbMe = ThisWorkbook
    With wbMe.Sheets("input_forecast").Rows("1:1")
        .Copy
        .PasteSpecial Paste:=xlPasteValues
        .NumberFormat = "YYYY-MM-DD"
    End With
    Application.CutCopyMode = False
    
    ' 配置应用参数
    Application.ScreenUpdating = False
    Application.UpdateLinks = xlUpdateLinksNever
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False
    
    ' ========== 自动找最新文件逻辑 ==========
    ThisMonth = Format(Date, "mmmm")
    MyFolder = "C:\Users\V1410191\Documents\Final" & ThisMonth & "\"
    ' 校验文件夹是否存在
    If Dir(MyFolder, vbDirectory) = "" Then
        MsgBox "当月文件夹不存在，请确认文件已生成", vbCritical
        GoTo 结束流程
    End If
    
    ' 遍历所有符合条件的文件，找最新的
    MyFile = Dir(MyFolder & "FinalPrice*.xlsm")
    If MyFile = "" Then
        MsgBox "文件过旧，未找到当月匹配的文件", vbExclamation
        GoTo 结束流程
    End If
    
    newestDate = #1/1/1900#
    Do Until MyFile = ""
        fileDate = FileDateTime(MyFolder & MyFile)
        If fileDate > newestDate Then
            newestDate = fileDate
            newestFile = MyFolder & MyFile
        End If
        MyFile = Dir
    Loop
    
    ' 打开最新文件
    On Error Resume Next
    Set data_wb = Workbooks.Open(newestFile, UpdateLinks:=0)
    On Error GoTo 0
    If data_wb Is Nothing Then
        MsgBox "文件打开失败，请确认文件未被占用", vbCritical
        GoTo 结束流程
    End If
    
    ' 校验目标工作表是否存在
    If IsError(Evaluate("'[" & data_wb.Name & "]Adekwatnosc'!A1")) Then
        MsgBox "目标文件中不存在Adekwatnosc工作表", vbCritical
        data_wb.Close SaveChanges:=False
        GoTo 结束流程
    End If
    
    ' ========== 业务逻辑处理 ==========
    ' 处理第一行日期格式，不需要Select
    With data_wb.Sheets("Adekwatnosc").Rows("1:1")
        .Value = .Value ' 直接转值，不需要复制粘贴
        .NumberFormat = "YYYY-MM-DD"
    End With
    
    ' 日期输入校验
    Do
        inputbx = InputBox("请输入日期，格式：YYYY-MM-DD", , Format(VBA.Now, "YYYY-MM-DD"))
        If inputbx = vbNullString Then GoTo 关闭文件
        On Error Resume Next
        vDate = DateValue(inputbx)
        On Error GoTo 0
        DateIsValid = IsDate(vDate)
        If Not DateIsValid Then MsgBox "请输入合法的日期格式", vbExclamation
    Loop Until DateIsValid
    
    ' 匹配日期并复制数据，不需要Activate
    With data_wb.Worksheets("Adekwatnosc")
        Set loc = .Cells.Find(what:=vDate, LookIn:=xlValues, LookAt:=xlWhole)
        If Not loc Is Nothing Then
            lc = .Cells(loc.Row, .Columns.Count).End(xlToLeft).Column
            .Range(.Cells(109, loc.Column), .Cells(123, lc)).Copy
            ' 匹配当前表的日期列
            Set locPaste = wbMe.Sheets("input_forecast").Cells.Find(what:=vDate, LookIn:=xlValues, LookAt:=xlWhole)
            If Not locPaste Is Nothing Then
                wbMe.Sheets("input_forecast").Cells(27, locPaste.Column).PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
                MsgBox "数据粘贴完成！"
            Else
                MsgBox "当前工作簿中未找到匹配的日期列", vbExclamation
            End If
        Else
            MsgBox "目标文件中未找到输入的日期", vbExclamation
        End If
    End With
    
关闭文件:
    data_wb.Close SaveChanges:=False
结束流程:
    ' 恢复应用参数
    Application.ScreenUpdating = True
    Application.UpdateLinks = xlUpdateLinksAlways
    Application.DisplayAlerts = True
    Application.AskToUpdateLinks = True
End Sub

优化点说明 #

• 新增了文件夹、文件、工作表三层存在性校验，所有异常场景都有对应提示，不会直接报错
• 新增了按文件修改时间排序取最新文件的逻辑，符合优先取最新文件的需求
• 移除了所有不必要的Select、Activate操作，大幅降低报错概率
• 补充了变量声明，添加了完整的异常退出逻辑，不会出现Excel配置被修改的问题

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