从MS Project复制到Excel时随机出现1004运行时错误求助

可能原因 #

• 剪贴板同步延迟：MS Project复制数据后，剪贴板可能未完全就绪就执行粘贴操作，导致PasteSpecial失败。
• 应用程序焦点冲突：代码执行时，MS Project和Excel之间的焦点切换不及时，引发粘贴操作异常。
• 剪贴板内容被意外覆盖：系统其他进程可能在代码执行期间占用剪贴板，导致目标内容丢失。

针对性解决办法 #

1. 增加剪贴板就绪等待机制 #

在复制和粘贴之间添加延迟，确保剪贴板完成数据写入。可以用Sleep函数（需声明API）：

' 声明Sleep API（放在模块顶部）
#If VBA7 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

' 示例：复制任务名称后等待再粘贴
MSProject.Application.SelectTaskColumn Column:="名称"
MSProject.Application.EditCopy
Sleep 500 ' 等待500毫秒确保剪贴板就绪
ThisWorkbook.Sheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteValues

2. 绕过剪贴板，直接通过对象模型读取数据 #

这是最可靠的方案，完全避免剪贴板相关问题，直接从MS Project对象获取数据写入Excel：

Dim proj As MSProject.Project
Dim tsk As MSProject.Task
Dim ws As Worksheet
Dim rowNum As Long

Set proj = MSProject.Application.ActiveProject
Set ws = ThisWorkbook.Sheets("Sheet1")
rowNum = 1

' 遍历任务写入Excel对应列
For Each tsk In proj.Tasks
    If Not tsk Is Nothing Then
        ws.Cells(rowNum, 1).Value = tsk.Name ' 任务名称
        ws.Cells(rowNum, 2).Value = tsk.Start ' 开始日期
        ws.Cells(rowNum, 3).Value = tsk.Finish ' 结束日期
        ' 按需添加其他需要的字段
        rowNum = rowNum + 1
    End If
Next tsk

3. 明确控制应用程序焦点 #

操作前激活目标应用程序，避免焦点混乱导致的异常：

' 复制前激活MS Project
MSProject.Application.Activate
MSProject.Application.SelectTaskColumn Column:="工期"
MSProject.Application.EditCopy

' 粘贴前激活Excel
Excel.Application.Activate
Sleep 200
ThisWorkbook.Sheets("Sheet1").Range("B1").PasteSpecial Paste:=xlPasteValues

4. 添加错误捕获与重试机制 #

针对随机错误，设置重试逻辑，触发错误时重试粘贴操作：

Dim retryCount As Integer
retryCount = 0

On Error Resume Next
RetryPaste:
ThisWorkbook.Sheets("Sheet1").Range("C1").PasteSpecial Paste:=xlPasteValues
If Err.Number = 1004 And retryCount < 3 Then
    retryCount = retryCount + 1
    Sleep 300
    Resume RetryPaste
End If
On Error GoTo 0

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