VBA关闭屏幕更新后读取未打开Excel不复制数据无报错如何修改

你的代码无响应、无输出也不报错主要是3个关键问题导致：

1. 你新建了独立的Excel实例app打开数据源文件，跨Excel实例的剪贴板复制粘贴默认不互通，导致复制完粘贴失败，也不会触发报错
2. Find方法未指定查找参数，日期匹配失败，代码直接跳过了粘贴逻辑
3. ScreenUpdating关闭时机错误，且程序结束没有恢复打开，会导致后续Excel界面无响应

• 删除额外新建的Excel实例逻辑，直接在当前实例打开数据源文件，避免跨实例操作问题
• 程序入口处关闭ScreenUpdating，所有逻辑执行完毕后强制恢复打开
• 补全Find方法的查找参数，确保日期可以正确匹配
• 移除所有不必要的Select、Activate操作，提升运行稳定性
• 补充变量声明，避免隐性变量错误

Option Explicit ' 强制变量声明，避免拼写错误

Sub Makro10()
    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 file_name As String
    Dim DateIsValid As Boolean
    
    ' 程序开始就关闭屏幕更新，真正实现后台运行
    Application.ScreenUpdating = False
    ' 禁用事件避免额外触发逻辑
    Application.EnableEvents = False
    
    Set wbMe = ActiveWorkbook
    ' 处理当前表表头格式
    With wbMe.Sheets("input_forecast").Rows("1:1")
        .Value = .Value ' 直接转值，不需要复制粘贴
        .NumberFormat = "YYYY-MM-DD"
    End With

    file_name = selectFilePK
    If file_name = "" Then GoTo Finally ' 走统一退出逻辑
    
    ' 直接在当前实例打开数据源，不要新建Excel实例
    Set data_wb = Workbooks.Open(file_name, ReadOnly:=True)
    ' 处理数据源表头格式
    With data_wb.Sheets("Final").Rows("1:1")
        .Value = .Value
        .NumberFormat = "YYYY-MM-DD"
    End With
    
    ' 日期输入校验逻辑
    Do
        inputbx = InputBox("Enter Date, FORMAT; YYYY-MM-DD", , Format(VBA.Now, "YYYY-MM-DD"))
        If inputbx = vbNullString Then GoTo CloseAndExit
        On Error Resume Next
        vDate = DateValue(inputbx)
        On Error GoTo 0
        DateIsValid = IsDate(vDate)
        If Not DateIsValid Then MsgBox "Please enter a valid date.", vbExclamation
    Loop Until DateIsValid
    
    ' 查找匹配日期和复制粘贴
    With data_wb.Worksheets("Final")
        ' 补全Find参数，确保日期准确匹配
        Set loc = .Cells.Find(What:=vDate, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
        If Not loc Is Nothing Then
            lc = .Cells(loc.Row, .Columns.Count).End(xlToLeft).Column
            ' 直接赋值，不需要用剪贴板复制粘贴，更稳定
            wbMe.Sheets("input_forecast").Cells(27, loc.Column).Resize(15, lc - loc.Column + 1).Value = _
                .Range(.Cells(109, loc.Column), .Cells(123, lc)).Value
        End If
    End With

CloseAndExit:
    data_wb.Close SaveChanges:=False
Finally:
    ' 一定要恢复屏幕更新和事件，否则Excel会卡住
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.CutCopyMode = False
End Sub

Private Function selectFilePK() As String
    Dim fd As Office.FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .InitialFileName = ActiveWorkbook.Path
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Excel", "*.xlsm"
        If .Show = True Then selectFilePK = .SelectedItems(1)
    End With
End Function

原来的复制粘贴逻辑改成了直接给单元格区域赋值，完全跳过剪贴板，运行速度更快，也不会和用户自己剪贴板里的内容冲突。

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