依据条件插入相应名称的文档，代码是成功了，请问有没有更简单的写法呢？

zyr6363

因为日常工作是做估价报告，估价报告由不同的文档组合而成的，我想让它自动化生成，写了以下的代码，大概意思是：

当表4中的文字是什么内容的时候，插入同名称的文档。

代码如下：（是不是可以遍历所有文档，然后选出和表格内容一样名字的文档的写法啊？）

Sub yinyong()

Dim doc As Document
Dim worDoc As Object
Dim tx



tx = ActiveDocument.Tables(4).Cell(2, 1).Range.Text
tv = ActiveDocument.Tables(4).Cell(3, 1).Range.Text

bx = "成本逼近法" & vbCr & Chr(7)
cx = "假设开发法" & vbCr & Chr(7)
dx = "基准地价系数修正法" & vbCr & Chr(7)
ex = "收益还原法" & vbCr & Chr(7)

If bx = tx Then
    Documents.Open ActiveDocument.Path & "\" & "成本逼近法.docx"
ActiveDocument.Content.Select
Selection.Copy
ActiveDocument.Close
Documents("估价报告.docm").Activate
ActiveDocument.Bookmarks("估价方法开始").Select
Selection.Move Unit:=wdLine, Count:=1
    Selection.Paste

ElseIf cx = tx Then
    Documents.Open ActiveDocument.Path & "\" & "假设开发法.docx"
ActiveDocument.Content.Select
Selection.Copy
ActiveDocument.Close
Documents("估价报告.docm").Activate
ActiveDocument.Bookmarks("估价方法开始").Select
Selection.Move Unit:=wdLine, Count:=1
    Selection.Paste

ElseIf dx = tx Then
    Documents.Open ActiveDocument.Path & "\" & "基准地价系数修正法.docx"
ActiveDocument.Content.Select
Selection.Copy
ActiveDocument.Close
Documents("估价报告.docm").Activate
ActiveDocument.Bookmarks("估价方法开始").Select
Selection.Move Unit:=wdLine, Count:=1
    Selection.Paste

Else
ex = tx
    Documents.Open ActiveDocument.Path & "\" & "收益还原法.docx"
ActiveDocument.Content.Select
Selection.Copy
ActiveDocument.Close
Documents("估价报告.docm").Activate
ActiveDocument.Bookmarks("估价方法开始").Select
Selection.Move Unit:=wdLine, Count:=1
    Selection.Paste
End If

End Sub

413191246se

楼主 最好上附件，说明之。

zyr6363

413191246se 发表于 2020-12-6 22:34
楼主 最好上附件，说明之。

好的，附件如下：

413191246se

谢谢 楼主！——表4 是不是——（二）估计方法  下面的这个表格？里面的单元格文本可以取得，但是相应文档插入到哪里呢？是右面的单元格吗？装不下啊！——楼主 应该用 红色 标明想要处理的文字或想要达成的效果。

zyr6363

413191246se 发表于 2020-12-7 22:30
谢谢 楼主！——表4 是不是——（二）估计方法  下面的这个表格？里面的单元格文本可以取得，但是相应文档 ...

首先表达感激之情！
表4是那个表格，插入的位置，我设置了2个书签，就在表格下面。

daibao88

Sub yinyong3()
    Dim doc As Document, d1 As Document, d2 As Document
    Dim tx, tv
    Set doc = ThisDocument
    tx = doc.Tables(4).Cell(2, 1).Range.Text
    tv = doc.Tables(4).Cell(3, 1).Range.Text
    tx = VBA.Left(tx, Len(tx) - 2)
    tv = VBA.Left(tv, Len(tv) - 2)
    tx = doc.Path & "\" & tx & ".docx"
    tv = doc.Path & "\" & tv & ".docx"
    If Dir(tx) <> "" Then
        Set d1 = Documents.Open(tx)
        d1.Content.Copy
        d1.Close
        doc.Activate
        doc.Bookmarks("估价方法开始").Select
        Selection.Move Unit:=wdLine, Count:=1
        Selection.Paste
    End If
    If Dir(tv) <> "" Then
        Set d2 = Documents.Open(tv)
        d2.Content.Copy
        d2.Close
        doc.Bookmarks("估价方法开始").Select
        Selection.Move Unit:=wdLine, Count:=1
        Selection.Paste
    End If
End Sub
不知道我是否理解的正确。