Question

我正在尝试在子文件夹中搜索文件名，打开Excel文件，然后复制/粘贴到Word。我的代码现在的方式是每次都会打开一个新的Word文档。如何将每个Excel文件中的一个项目粘贴到同一个Word文档中？

Sub Word(f)
    Set objWord = CreateObject("Word.Application")
    Set objDoc = objWord.Documents.Add("C:\Users\ntunstall\Desktop\test\Doc1.docx")
    objWord.Visible = True
    objDoc.PageSetup.Orientation = 1
    objDoc.Paragraphs.Alignment = 1

    Set objExcel = CreateObject("Excel.Application")
    Set objWkb = objExcel.Workbooks.Open(f)
    objExcel.Visible = False

    objWkb.Sheets("PresRate").ChartObjects("Chart 1").CopyPicture
    objWord.Selection.Paste
    objWord.Selection.MoveRight
    objWord.Selection.TypeParagraph

    objWkb.Save
    objWkb.Close
End Sub

Dim path: path = "C:\Users\ntunstall\Desktop\test"
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
Call TraverseFolders(fso.GetFolder(path))

Sub TraverseFolders(fldr)
  Dim f, sf
  For Each f In fldr.Files
    If InStr(f.Name, "OPS") > 0 Then
        If InStr(f.Name, "xlsm") > 0 Then
            Call Word(f)
        End If
    End If
  Next

  For Each sf In fldr.SubFolders
    Call TraverseFolders(sf)
  Next
End Sub

wScript.Quit
objWord.Quit
objExcel.Quit

Set objDoc = Nothing
Set objWkb = Nothing

我尝试将Sub Word(f)的部分移入/移出子，以及移出/移出Sub TraverseFolders(fldr)。对象要么超出范围，要么程序仍会打开多个word文档。

Answer 1

您需要移动启动Word的代码并从过程Word创建一个新文档到全局范围。我还会将Excel对象的创建移动到全局范围，因为您只需要一个实例。

改变这个：

Sub Word(f)
    Set objWord = CreateObject("Word.Application")
    Set objDoc = objWord.Documents.Add("C:\Users\ntunstall\Desktop\test\Doc1.docx")
    objWord.Visible = True
    objDoc.PageSetup.Orientation = 1
    objDoc.Paragraphs.Alignment = 1

    Set objExcel = CreateObject("Excel.Application")
    Set objWkb = objExcel.Workbooks.Open(f)
    objExcel.Visible = False

    objWkb.Sheets("PresRate").ChartObjects("Chart 1").CopyPicture
    objWord.Selection.Paste
    objWord.Selection.MoveRight
    objWord.Selection.TypeParagraph

    objWkb.Save
    objWkb.Close
End Sub

Dim path: path = "C:\Users\ntunstall\Desktop\test"
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
Call TraverseFolders(fso.GetFolder(path))

到此：

Sub Word(f)
    Set objWkb = objExcel.Workbooks.Open(f)

    objWkb.Sheets("PresRate").ChartObjects("Chart 1").CopyPicture
    objWord.Selection.Paste
    objWord.Selection.MoveRight
    objWord.Selection.TypeParagraph

    objWkb.Save
    objWkb.Close
End Sub

Dim path: path = "C:\Users\ntunstall\Desktop\test"
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")

Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add("C:\Users\ntunstall\Desktop\test\Doc1.docx")
objWord.Visible = True
objDoc.PageSetup.Orientation = 1
objDoc.Paragraphs.Alignment = 1

Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False

Call TraverseFolders(fso.GetFolder(path))

同样改变这个：

WScript.Quit
objWord.Quit
objExcel.Quit

Set objDoc = Nothing
Set objWkb = Nothing

到此：

objExcel.Quit

因为当您显然只想保留Word实例时，调用WScript.Quit会先运行Word 和 Excel实例，并且在脚本终止时会自动清除变量。

如何防止Word在递归期间打开多个文档？

1 个答案: