ActiveSheet.PasteSpecial

Question

我有一个宏可以在后端打开Word文档，并将所有数据表拉入Excel模板。

当我在一些同事中测试时，＆＃39;机器，他们得到＆＃34; VBA PasteSpecial错误＆＃34;。

我查看了参考资料并在同事中添加了内容。机器是我的机器。

Dim sht As Worksheet
Dim WordDoc As Word.Document
Dim WordApp As Word.Application
Dim i As Long, r As Long, c As Long
Dim rng As Range, t As Word.Table
Dim ia As Integer
Dim OpenForms
Dim target As Range
ia = 1
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Set WordDoc = WordApp.Documents.Open(DOC_PATH, ReadOnly:=True)
Set sht = Sheets("test")
Set rng = sht.Range("A5")
sht.Activate
For Each t In WordDoc.Tables
    OpenForms = DoEvents
    t.Range.Copy
    OpenForms = DoEvents
    ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Table_" & ia ' add new sheet
    Range("a1").Select ' paste table
    ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
    OpenForms = DoEvents

Answer 1

修改

OP将此问题诊断为并发问题，其中未及时复制剪贴板以进行粘贴操作。下面的代码将解决此问题，同时保持响应式用户界面和合理的超时和通知。

On Error Resume Next
Dim TimeoutLimit
TimeoutLimit = 300
Dim TimeoutCounter
TimeoutCounter = 0
Do
    Err.Clear
    DoEvents 'Yield thread execution
    ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
    TimeoutCounter = TimeoutCounter + 1
Loop Until (Err.Number = 0 Or TimeoutCounter > TimeoutLimit )
On Error GoTo 0
If TimeoutCounter > TimeoutLimit Then
    MsgBox "Paste failed because of operation timeout", vbCritical
    'Is this fatal? Abort by proper exiting...
    'Exit Sub
    'Exit Function
End If

我认为您使用ActiveSheet.PasteSpecial可能很好，基于您已经完成的测试和此MSDN Documentation。但是，您的问题可能是您获得的数据与text格式不相容，如下所述。

关于该方法，Worksheet.PasteSpecial方法与Range.PasteSpecial完全不同。我觉得奇怪的是，如果你正在调用工作表方法，你得到的错误表明范围方法失败了。如果这是准确的，我怀疑Worksheet方法在某个时候调用range方法。

我可以重现特定的错误

  

Range类的PasteSpecial方法失败

在以下条件下

用于Range.PasteSpecial：

• 剪贴板为空
• 未从Office复制数据 应用

原来，有办公室剪贴板和Windows剪贴板。例如，Application.CutCopyMode仅控制办公室剪贴板。 Range.PasteSpecial在Office剪贴板之外工作，而Workbook.PasteSpecial在系统或Windows剪贴板之外工作。因此，如果办公室剪贴板为空，它不会抛出错误，事实上，如果强制使用Text作为其格式，则会在复制excel范围的相反条件下抛出错误。

  

Worksheet类的PasteSpecial方法失败

如果剪贴板数据无法转换为文本（如图片），它也会抛出此错误。您可以通过不指定格式来处理此问题，并使用默认格式。它不一定是文本，但这解决了粘贴Excel范围的错误。

要弄清楚这一点并检查剪贴板内容的存储方式，请从Excel查看，如下所示。

由于有可能一件事或另一件事可能会在不同条件下给你不同的问题，你可以尝试逐步完成这样的选择......

On Error Resume Next
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
If Err > 0 Then
    Err.Clear
    ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
    If Err > 0 Then
        Err.Clear
        'You could also try to manually retrieve data from clipboard at this point
        ActiveSheet.PasteSpecial
    End If
End If
On Error GoTo 0

正如我在评论中所说，PasteSpecial可能很挑剔。因此，我建议删除它作为一个因素并测试您是否可以直接访问剪贴板内容，如下面的代码（copied from here）...

Sub GetClipBoardText()
   Dim DataObj As MSForms.DataObject
   Set DataObj = New MsForms.DataObject '<~~ Amended as per jp's suggestion

   On Error GoTo Whoa

   '~~> Get data from the clipboard.
   DataObj.GetFromClipboard

   '~~> Get clipboard contents
   myString = DataObj.GetText(1)
   MsgBox myString

   Exit Sub
Whoa:
   If Err <> 0 Then MsgBox "Data on clipboard is not text or is empty"
End Sub

请参阅此documented case of the same error，这是由于剪贴板为空而导致Office宏发生这种情况的容易程度。您正在宏中复制，所以我不希望这是您的问题。此外，此代码段将防止Range方法的null，而不是Worksheet方法，因为它只检查应用程序的剪贴板而不是系统的剪贴板。

If Application.CutCopyMode = True Then
  ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
Else
  MsgBox("There is no data on the clipboard to be pasted.")
End If

Answer 2

.PasteSpecial是Range object的方法，而不是Worksheet object。 .Paste是Worksheet object的一种方法。

尝试更换，

ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Table_" & ia ' add new sheet
Range("a1").Select ' paste table
ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False

...用，

ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Table_" & ia ' add new sheet
ActiveSheet.Range("a1").PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False

Answer 3

@Rin和@最好添加等待功能以减少CPU负载。 Application.Wait(Now + TimeValue("0:00:10"))'等待10秒或根据需要确保循环不会使cpu过载，我们可以减少TimeoutCounter

--revised code sample-
On Error Resume Next
Dim TimeoutLimit
TimeoutLimit = 6 'counter reduced to 6 attempts
Dim TimeoutCounter
TimeoutCounter = 0
Do
    Err.Clear
    DoEvents 'Yield thread execution
    ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
        If Err.Number <> 0 Then Application.Wait (Now + TimeValue("00:00:10")) 'reduces CPU load
    TimeoutCounter = TimeoutCounter + 1
Loop Until (Err.Number = 0 Or TimeoutCounter > TimeoutLimit )
On Error GoTo 0
If TimeoutCounter > TimeoutLimit Then
    MsgBox "Paste failed because of operation timeout", vbCritical
    'Is this fatal? Abort by proper exiting...
    'Exit Sub
    'Exit Function
End If
--------------