求助：Word表格复制修改，求高手，不胜感激

朔方

.PasteSpecial '出现错误提示，点击继续，调试继续则第一个表格复制成功，再重复操作，到结束。？？咋修改去掉错误提示。

vbee

电脑慢了， 21版正常

.COPY后等1秒

朔方

vbee 发表于 2024-6-1 11:38
电脑慢了， 21版正常

.COPY后等1秒

是2019版的，.PasteSpecial ' 出现错误提示，不知道为啥

朔方

2019版的，.PasteSpecial ' 出现错误提示，不清楚为啥

batmanbbs

凡是使用.copy或者.cut之后都需要增加延时，等待数据完整写入剪贴板中才行

gwjkkkkk

Option Explicit
Sub test1()
    Dim ar(), i&, r&, objTable As Table
   
    Application.ScreenUpdating = False
   
    With ThisDocument
        For Each objTable In .Tables
            r = r + 1
            ReDim Preserve ar(1 To r)
            Set ar(r) = objTable.Range
        Next
    End With
   
    If r = 0 Then Exit Sub
    With Documents.Add
        With Selection
            For i = 1 To UBound(ar)
                If i > 1 Then .InsertBreak (6)
                ar(i).Copy
                .Paste
            Next i
        End With
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

重写一个。。。

朔方

gwjkkkkk 发表于 2024-6-1 12:57
重写一个。。。

谢谢了，  .Paste  提示命令无效，替换成PasteSpecial，还是和原来一样，看来是我电脑的问题了，十分感谢了

朔方

gwjkkkkk 发表于 2024-6-1 12:57
重写一个。。。

重启下电脑，正常了，再次感谢啊

413191246se

* 楼主，我发一下免费的《微软官方VBA帮助》VBAWD10.CHM 中的代码示例，仅供参考：
   
* 将活动文档中的所有表格复制到新文档中
本示例将当前文档中的表格复制到新文档中。

Sub CopyTablesToNewDoc()
    Dim docOld As Document
    Dim rngDoc As Range
    Dim tblDoc As Table

    If ActiveDocument.Tables.Count >= 1 Then
        Set docOld = ActiveDocument
        Set rngDoc = Documents.Add.Range(Start:=0, End:=0)
        For Each tblDoc In docOld.Tables
            tblDoc.Range.Copy
            With rngDoc
                .Paste
                .Collapse Direction:=wdCollapseEnd
                .InsertParagraphAfter
                .Collapse Direction:=wdCollapseEnd
            End With
        Next
    End If
End Sub