1

複数の Word ファイルを 1 つに結合しようとしています。MS Excel の VBA ルーチン内でこれを行っています。Wordファイルはすべて「files」という名前のフォルダーにあり、その1つ上のフォルダーに新しいファイル「combinedfile.docx」を作成したいと考えています。私が直面している問題は、ファイルをマージした後に Word プロセスがどのように動作するか (VBA 関数の実行後に終了するかどうか) に関するものです。一部のマシンでは、このプロセスは正常に機能しますが (ページ 2 と最後のページが空白であることを除いて)、一部のマシンでは、マージされたドキュメントに空白のページが含まれ、プロセス マネージャーは VBA 関数によって開始された Word プロセスをまだとして表示します。ランニング。

  1. 私は VBA プログラミングに慣れていません。下のコードでわかるように、開いているドキュメントを閉じて、開いている Word プロセスを終了する正しい方法がわかりません。誰かが私がやったことを見て、この問題を解決する方法を提案できれば、それは非常に役に立ちます.

  2. これが複数の Word ファイルをマージする正しい方法であるかどうかも知りたいです。より良い方法があれば、私に知らせてください。


    'the flow:
    '  start a word process to create a blank file "combinedfile.docx"
    '  loop over all documents in "files" folder and do the following:
    '    open the file, insert it at the end of combinedfile.docx, then insert pagebreak
    '  close the file and exit the word process

    filesdir = ActiveWorkbook.Path + "\" + "files\"
    thisdir = ActiveWorkbook.Path + "\"
    singlefile = thisdir + "combinedfile.docx"

    'if it already exists, delete
    If FileExists(singlefile) Then
      SetAttr singlefile, vbNormal
      Kill singlefile
    End If

    Dim wordapp As Word.Application
    Dim singledoc As Word.Document
    Set wordapp = New Word.Application
    Set singledoc = wordapp.Documents.Add
    wordapp.Visible = True
    singledoc.SaveAs Filename:=singlefile
    singledoc.Close    'i do both this and the line below (is it necessary?)
    Set singledoc = Nothing
    wordapp.Quit
    Set wordapp = Nothing

    JoinFiles filesdir + "*.docx", singlefile

    Sub JoinFiles(alldocs As String, singledoc As String)
      Dim wordapp As Word.Application
      Dim doc As Word.Document
      Set wordapp = New Word.Application
      Set doc = wordapp.Documents.Open(Filename:=singledoc)
      Dim filesdir As String
      filesdir = ActiveWorkbook.Path + "\" + "files\"

      docpath = Dir(alldocs, vbNormal)

      While docpath  ""
        doc.Bookmarks("\EndOfDoc").Range.InsertFile (filesdir + docpath)
        doc.Bookmarks("\EndOfDoc").Range.InsertBreak Type:=wdPageBreak
        docpath = Dir
      Wend
      doc.Save
      doc.Close
      Set doc = Nothing
      wordapp.Quit
      Set wordapp = Nothing  
    End Sub
4

1 に答える 1

2

次の方法でコードを最適化することを提案します。

  • WordApp を 1 回だけ開き、閉じたり再度開いたりせずにファイルをそこに移動する
  • 事前に結合文書を強制終了する必要はありません。新しいファイルによって単純に上書きされます。
  • Word.Document オブジェクトは必要ありません。すべて Word.Application オブジェクトで実行できます。

そのため、コードは非常に単純になります。

Sub Merge()
Dim WordApp As Word.Application
Dim FilesDir As String, ThisDir As String, SingleFile As String, DocPath As String
Dim FNArray() As String, Idx As Long, Jdx As Long ' NEW 11-Apr-2013

    FilesDir = ActiveWorkbook.Path + "\" + "files\"
    ThisDir = ActiveWorkbook.Path + "\"
    SingleFile = ThisDir + "combinedfile.docx"
    Set WordApp = New Word.Application

' NEW 11-Apr-2013 START
    ' read in into array
    Idx = 0
    ReDim FNArray(Idx)
    FNArray(Idx) = Dir(FilesDir & "*.docx")
    Do While FNArray(Idx) <> ""
        Idx = Idx + 1
        ReDim Preserve FNArray(Idx)
        FNArray(Idx) = Dir()
    Loop
    ReDim Preserve FNArray(Idx - 1) ' to get rid of last blank element
    BubbleSort FNArray
' NEW 11-Apr-2013 END

    With WordApp
        .Documents.Add
        .Visible = True

' REMOVED 11-Apr-2013 DocPath = Dir(FilesDir & "*.docx")
' REMOVED 11-Apr-2013 Do While DocPath <> ""
' REMOVED 11-Apr-2013     .Selection.InsertFile FilesDir & DocPath
' REMOVED 11-Apr-2013     .Selection.TypeBackspace
' REMOVED 11-Apr-2013     .Selection.InsertBreak wdPageBreak
' REMOVED 11-Apr-2013     DocPath = Dir
' REMOVED 11-Apr-2013 Loop

' NEW 11-Apr-2013 START
        For Jdx = 0 To Idx - 1
            .Selection.InsertFile FilesDir & FNArray(Jdx)
            .Selection.TypeBackspace
            .Selection.InsertBreak wdPageBreak
        Next Jdx
' NEW 11-Apr-2013 END

        .Selection.TypeBackspace
        .Selection.TypeBackspace
        .Selection.Document.SaveAs SingleFile
        .Quit
    End With
    Set WordApp = Nothing
End Sub

' NEW 11-Apr-2013 START
Sub BubbleSort(Arr)
Dim strTemp As String
Dim Idx As Long, Jdx As Long
Dim VMin As Long, VMax As Long

    VMin = LBound(Arr)
    VMax = UBound(Arr)

    For Idx = VMin To VMax - 1
        For Jdx = Idx + 1 To VMax
            If Arr(Idx) > Arr(Jdx) Then
                strTemp = Arr(Idx)
                Arr(Idx) = Arr(Jdx)
                Arr(Jdx) = strTemp
            End If
        Next Jdx
    Next Idx
End Sub
' NEW 11-Apr-2013 END

編集 2013 年 4 月 11 日 、コード内の元のコメントを削除し、配列とバブルソート ロジックを追加して、ファイルがアルファベット順に取得されるようにしました。

于 2013-04-09T07:50:47.503 に答える