两份文档交替插入出现问题，望大大们解决下。跪谢！

TK121

大大，能否帮我解决下，我是纯新人。。我需要把两个文件交替粘贴，但是遇到表格位置要出错，还有就是粘贴的时候怎么保留原文样式呢，希望帮忙解决下，万分感谢。跪谢！！！这些都是我在网上东拼西凑的，再次感谢。。
Sub 单语改双语()
Dim MyDialog As FileDialog, vrtSelectedItem As Variant, Doc As Document
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Title = "请选择要处理的文档（可多选）"
.Filters.Clear '清除所有文件筛选器中的项目
.Filters.Add "所有WORD 文件", "*.docx", 1 '增加筛选器的项目为所有WORD文件
.AllowMultiSelect = True '允许多项选择
If .Show = -1 Then '确定
For Each vrtSelectedItem In .SelectedItems '在所有选取项目中循环
Set Doc = Documents.Open(FileName:=vrtSelectedItem, Visible:=False)
单语改双语进程 Doc
Doc.Close
Next
End If
End With
End Sub
Sub 单语改双语进程(ByVal Doc As Document)
Dim n As Integer, cp As Paragraph
If MsgBox("此文件段落数：" & ActiveDocument.Paragraphs.Count & Chr(13) & "新打开的文件段落数：" & Doc.Paragraphs.Count & Chr(13) & Chr(13) & "请确认是否继续！", vbYesNo, "是否继续单语改双语") = vbNo Then
    MsgBox "已取消！"
    Exit Sub
End If
For n = Doc.Paragraphs.Count To 1 Step -1
    On Error Resume Next
    Set cp = Doc.Paragraphs(n)
    Set ep = ActiveDocument.Paragraphs(n).Range
    ep.InsertAfter Text:=cp.Range.Text
Next
End Sub

413191246se

* 楼主，你提供的代码运行不正确！请试用我的代码（请同时打开附件中 1、2 两个文档后应用）：

1. Sub Chinese_English_View()
   
2.     Dim i&
   
3.     Documents("1.docx").Activate
   
4.     With Selection
   
5.         .HomeKey 6
   
6.         Do
   
7.             i = i + 1
   
8.             If .Paragraphs(1).Range.End = ActiveDocument.Content.End Then Exit Do
   
9.             If Asc(.Paragraphs(1).Range) = 13 Then .MoveRight: i = i + 1
   
10.             If Asc(.Paragraphs(1).Range) = 13 Then .MoveRight: i = i + 1
    
11.             .Paragraphs(1).Range.Characters.Last.InsertBefore Text:= _
    
12.                 vbCr & Replace(Documents("2.docx").Paragraphs(i).Range.Text, vbCr, "")
    
13.             .Move 4, 2
    
14.         Loop
    
15.         .HomeKey 6
    
16.     End With
    
17. End Sub

复制代码

zhanglei1371

formattedtext属性，了解一下

TK121

413191246se 发表于 2021-1-9 00:48
* 楼主，你提供的代码运行不正确！请试用我的代码（请同时打开附件中 1、2 两个文档后应用）：

413191246se大大，我经常看到你的回复，感谢对新人的解答。     如果我想粘贴带格式的文本能否解决呢，还有给你的代码最后一行不能处理，增加一个段落就能解决了。

413191246se

楼主，合并后可以简单地分别设置中英文字体；要想带格式，我的代码现在做不到。

TK121

413191246se 发表于 2021-1-9 19:14
楼主，合并后可以简单地分别设置中英文字体；要想带格式，我的代码现在做不到。

413191246se，大大，感谢你再次的回复，客户给的稿件设置很多，且都不一样，故而带格式是一个好的选择。楼上zhanglei1371说的是可以返回格式的，但是遇到表格还是要出问题。一直解决不到。下面的代码是在你之前给我的基础上修改的。
            If Asc(.Paragraphs(1).Range) = 12 And Len(.Paragraphs(1).Range) <= 2 Then '只有分节符和分页符的段落
                .MoveRight
                .Move 4, 1
                If Len(.Paragraphs(1).Range) > 2 Then
                    .Paragraphs(1).Range.Characters(2).InsertBefore Text:=vbCr
                End If
                i = i + 1
            Else
                .Paragraphs(1).Range.Characters.Last.InsertBefore Text:=vbCr '后面加一段落
                .MoveDown wdParagraph
                If Asc(Documents("2.docx").Paragraphs(i).Range) <> 12 Then
                    .FormattedText = Documents("2.docx").Paragraphs(i).Range '带格式粘贴
                    .Move 4, 1
                    .Delete
                    .Move 4, 1
                Else
                    .FormattedText = Documents("2.docx").Paragraphs(i).Next.Range
                End If
            End If