跨独立Excel实例复制粘贴的VBA代码问题求助

看起来你遇到了两个核心问题：一是原代码只能复制保存到磁盘的旧数据，拿不到当前打开实例里的实时修改；二是代码只能在目标工作簿里运行，灵活性太差。下面我给你一套彻底解决这两个问题的方案。

为什么原代码不好用？ #

先拆解下原代码的问题：

• GetObject("Test two.xlsm")的坑：当目标工作簿在另一个独立Excel实例中打开时，这个函数经常会读取磁盘上的保存版本，而不是当前实例中你正在编辑的实时数据。
• 硬编码目标工作簿：Workbooks("Test three.xlsm")只能在目标工作簿所在的实例中生效，如果在其他实例运行代码，会直接报错找不到这个工作簿。

改进后的完整代码 #

这个方案通过Windows API枚举所有正在运行的Excel实例，精准找到你要的工作簿，并且直接读取内存中的实时数据，还能在任意Excel窗口中运行：

' 这些API声明要放在模块的最顶部（所有Sub/Function之外）
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
    (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
    ByVal lpsz2 As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" _
    (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" _
    (ByVal hWnd As Long, ByVal dwId As Long, riid As GUID, ppvObject As Object) As Long

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Sub CollectLiveDataAcrossInstances()
    ' --------------------------
    ' 在这里修改你的源/目标参数
    ' --------------------------
    Const SRC_WB_NAME As String = "Test two.xlsm"       ' 源工作簿名称
    Const DEST_WB_NAME As String = "Test three.xlsm"    ' 目标工作簿名称
    Const SRC_SHEET As String = "Sheet1"               ' 源数据所在工作表
    Const DEST_SHEET As String = "Sheet1"              ' 目标数据工作表
    Const SRC_RANGE As String = "A1"                   ' 要复制的源区域
    Const DEST_RANGE As String = "B1"                  ' 粘贴的目标起始位置
    
    Dim srcWorkbook As Workbook
    Dim destWorkbook As Workbook
    
    ' 查找源工作簿（跨所有Excel实例）
    Set srcWorkbook = GetWorkbookFromAnyInstance(SRC_WB_NAME)
    If srcWorkbook Is Nothing Then
        MsgBox "找不到已打开的源工作簿：" & SRC_WB_NAME, vbExclamation
        Exit Sub
    End If
    
    ' 查找目标工作簿（跨所有Excel实例）
    Set destWorkbook = GetWorkbookFromAnyInstance(DEST_WB_NAME)
    If destWorkbook Is Nothing Then
        MsgBox "找不到已打开的目标工作簿：" & DEST_WB_NAME, vbExclamation
        Exit Sub
    End If
    
    ' 直接赋值传递数据（避免剪贴板依赖，更高效）
    destWorkbook.Worksheets(DEST_SHEET).Range(DEST_RANGE).Value = _
        srcWorkbook.Worksheets(SRC_SHEET).Range(SRC_RANGE).Value
    
    MsgBox "实时数据复制完成！", vbInformation
End Sub

' 辅助函数：遍历所有Excel实例，找到指定名称的工作簿
Private Function GetWorkbookFromAnyInstance(targetWbName As String) As Workbook
    Dim mainWindowHandle As Long
    Dim childWindowHandle As Long
    Dim processId As Long
    Dim excelApp As Application
    Dim currentWb As Workbook
    Dim iIDispatch As GUID
    
    ' 设置GUID，用于AccessibleObjectFromWindow获取Excel实例
    With iIDispatch
        .Data1 = &H20400
        .Data2 = &H0
        .Data3 = &H0
        .Data4(0) = &HC0
        .Data4(1) = &H0
        .Data4(2) = &H0
        .Data4(3) = &H0
        .Data4(4) = &H0
        .Data4(5) = &H0
        .Data4(6) = &H0
        .Data4(7) = &H46
    End With
    
    ' 遍历所有Excel主窗口（XLMAIN是Excel窗口类名）
    mainWindowHandle = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
    Do While mainWindowHandle <> 0
        ' 获取当前窗口的进程ID
        GetWindowThreadProcessId mainWindowHandle, processId
        
        ' 找到Excel的子窗口，用于获取应用实例
        childWindowHandle = FindWindowEx(mainWindowHandle, 0&, "XLDESK", vbNullString)
        childWindowHandle = FindWindowEx(childWindowHandle, 0&, "EXCEL7", vbNullString)
        
        If childWindowHandle <> 0 Then
            ' 获取该窗口对应的Excel应用实例
            If AccessibleObjectFromWindow(childWindowHandle, &HFFFFFFF0, iIDispatch, excelApp) = 0 Then
                ' 遍历这个实例下的所有工作簿
                For Each currentWb In excelApp.Workbooks
                    If currentWb.Name = targetWbName Then
                        Set GetWorkbookFromAnyInstance = currentWb
                        Exit Function
                    End If
                Next
            End If
        End If
        
        ' 查找下一个Excel窗口
        mainWindowHandle = FindWindowEx(0&, mainWindowHandle, "XLMAIN", vbNullString)
    Loop
    
    ' 没找到对应工作簿，返回Nothing
    Set GetWorkbookFromAnyInstance = Nothing
End Function

怎么用？ #

1. 确保你的源工作簿（Test two.xlsm）和目标工作簿（Test three.xlsm）都已经打开（可以在不同的Excel实例中）。
2. 打开任意一个Excel文件，按下Alt+F11打开VBA编辑器。
3. 右键点击左侧的项目面板，选择「插入」→「模块」。
4. 把上面的代码粘贴到新建的模块里。
5. 根据你的实际情况修改代码开头的参数（比如工作表名、区域地址）。
6. 点击运行按钮（或者按下F5）执行CollectLiveDataAcrossInstances宏，就能完成实时数据复制了。

这个方案的优势 #

• 拿到实时数据：通过API枚举所有Excel实例，直接读取内存中的工作簿对象，不管你有没有保存，都能获取当前最新的内容。
• 灵活运行：不需要在目标工作簿里运行代码，只要两个工作簿都打开，在任意Excel窗口里都能执行。
• 更高效可靠：直接通过赋值传递数据，不用依赖剪贴板，避免了复制粘贴可能带来的冲突。

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