概要
フォルダに格納されているWordファイルを結合します。
指定フォルダ直下のみ処理します（サブフォルダ配下は対象外）。
注意事項
VBAがどうというより、Wordの結合時の仕様として気をつけること。
- 結合元のファイルで同じテンプレート（同じスタイル）を使っていないとスタイルが変更されることがあります。
- 改行の動きとか、クセがあります（2文書結合しようとして、1文書目末尾に改行が入ってないと2文書目の冒頭と文がつながります。1文書目末尾の改行については処理を追加することもできそうです）
ソース
Sub ファイル結合()
Dim StartTime As Date '開始時間
Dim EndTime As Date '終了時間
Dim WSH As Variant 'WSH(Windows Scripting Host)
Dim DefaultPath As String 'フォルダダイアログで開くときのデフォルトパス
Dim FSO As Object 'ファイルシステムオブジェクト
Dim FolderPath As String 'ダイアログで指定されたフォルダパス
Dim objFolder As Object 'フォルダオブジェクト
Dim objFiles As Object 'ファイルオブジェクト
Dim objF As Object 'ファイルオブジェクト用for文変数
Dim FileCount As Long '処理するファイル数
Dim FilePaths() '処理するファイルパス（配列）
Dim i As Long
Dim k As Long
Dim temp As String 'ソート用変数
Dim docWord1 As Document 'Wordファイル（1ファイル目）
Dim docWord2 As Document 'Wordファイル（2ファイル目以降）
Dim SectionBreakFlag As Boolean '結合時のセクション区切りフラグ（True：入れる、False：入れない）
Dim MsgRtn As Long
Dim strOutputFolder As String '出力先フォルダ
Const JoinFormat As Long = wdFormatOriginalFormatting '元のスタイル保持
''Const JoinFormat As Long = wdUseDestinationStylesRecovery '貼り付け先のスタイル利用
StartTime = Now() '開始時間
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSH = CreateObject("WScript.Shell")
'--------------------------------------
'フォルダと直下のファイルを取得
'--------------------------------------
'フォルダダイアログ
DefaultPath = WSH.SpecialFolders("Desktop") & "\" 'デスクトップに指定
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = DefaultPath 'デフォルトフォルダをデスクトップにする
If .Show = True Then
FolderPath = .SelectedItems(1)
End If
End With
'フォルダダイアログで「キャンセル」したので終了
If FolderPath = "" Then Exit Sub
'フォルダ取得
Set objFolder = FSO.GetFolder(FolderPath)
'ファイルが1つもない場合は終了
If objFolder.Files.Count = 0 Then
'終了メッセージ
MsgBox "指定されたフォルダにはファイルが1つもないので、終了します。", _
vbOKOnly + vbExclamation
Exit Sub
End If
'ファイル取得
Set objFiles = objFolder.Files
'--------------------------------------
'ファイルパスを取得
'--------------------------------------
'処理するファイル数の初期化
FileCount = 0
For Each objF In objFiles
'Wordのファイルのみ処理
If LCase(FSO.GetExtensionName(objF.Name)) = "doc" Or _
LCase(FSO.GetExtensionName(objF.Name)) = "docx" Then
'ファイルカウント
FileCount = FileCount + 1
'ファイルパスを取得するための動的配列を定義
If FileCount = 1 Then
ReDim FilePaths(FileCount)
Else
ReDim Preserve FilePaths(FileCount)
End If
'ファイルパスを配列に格納
FilePaths(FileCount) = objF
End If
Next objF
'処理対象のファイルが1つ以下の場合は終了
If FileCount = 0 Then
'終了メッセージ
MsgBox "指定されたフォルダには処理対象となるファイルが1つもないので、終了します。", _
vbOKOnly + vbExclamation
Exit Sub
ElseIf FileCount = 1 Then
'終了メッセージ
MsgBox "指定されたフォルダには処理対象となるファイルが1つしかないので結合不要です。終了します。", _
vbOKOnly + vbExclamation
Exit Sub
End If
'--------------------------------------
'ファイルパスをソート（ファイル名の昇順で結合するため）
'--------------------------------------
For i = 1 To FileCount
For k = FileCount To 1
If FilePaths(i) > FilePaths(k) Then
temp = FilePaths(i)
FilePaths(i) = FilePaths(k)
FilePaths(k) = temp
End If
Next k
Next i
'--------------------------------------
'結合オプション選択
'--------------------------------------
MsgRtn = MsgBox("結合時に、セクション区切りを入れますか？" & _
vbCrLf & vbCrLf & _
"はい ：セクション区切りを入れる" & vbCrLf & _
"いいえ：セクション区切りを入れない", _
vbYesNo + vbInformation)
If MsgRtn = vbYes Then
SectionBreakFlag = True
ElseIf MsgRtn = vbNo Then
SectionBreakFlag = False
End If
'--------------------------------------
'ファイルを開く
'--------------------------------------
For i = 1 To FileCount
If i = 1 Then
'ファイルを開く
Documents.Open FilePaths(i), ReadOnly:=True
Set docWord1 = ActiveDocument
docWord1.Repaginate '改ページ自動調整
Else
'セクション区切りを入れる場合
If SectionBreakFlag = True Then
'カーソル位置を最後に
Selection.EndKey unit:=wdStory
'ファイルを開く
Documents.Open FilePaths(i), ReadOnly:=True
Set docWord2 = ActiveDocument
docWord2.Repaginate '改ページ自動調整
'コピー
Selection.WholeStory
Selection.Copy
'セクション区切りを入れて貼り付け
docWord1.Activate
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.PasteAndFormat (JoinFormat)
'ファイルを閉じる
docWord2.Close SaveChanges:=False
'セクション区切りを入れない場合
Else
'カーソル位置を最後に
Selection.EndKey unit:=wdStory
'1ファイル目の最後に空行がないと、1ファイル目の最後の行と
'2ファイルの最初の行がつながってしまうので改行されてなければ改行。
'カーソル前が改行のASC(13)か判別する。
'ASC(11)は2ファイル目の最初の行のスタイルが意図せず変わる可能性があるので不可
If Asc(Selection.Characters.Last.Previous) = 13 Then
Else
'改行
Selection.TypeParagraph
End If
'結合
Selection.InsertFile FileName:=FilePaths(i)
End If
End If
Next i
'--------------------------------------
'結合したファイルの出力先フォルダを作成
'--------------------------------------
Do
strOutputFolder = FolderPath & "\" & "join_" & Format(Now(), "yymmdd_hhmmss")
'フォルダがなかったら
If FSO.FolderExists(strOutputFolder) = False Then
'フォルダ作成
On Error Resume Next
FSO.CreateFolder (strOutputFolder)
If Err.Number = 0 Then
On Error GoTo 0
Exit Do
Else
MsgBox "出力用フォルダを作成できませんでした。「" & docWord1.Name & "」を自分で保存してください。" & _
vbCrLf & vbCrLf & _
Err.Number & " : " & Err.Description, _
vbOKOnly + vbExclamation
Exit Sub
End If
End If
Loop
'--------------------------------------
'結合したファイルを保存して閉じる
'--------------------------------------
docWord1.SaveAs FileName:=strOutputFolder & "\" & FSO.GetBaseName(docWord1.Name) & _
"_結合_" & Format(Now(), "yymmdd_hhmmss") & "." & FSO.GetExtensionName(docWord1.Name)
docWord1.Close SaveChanges:=wdDoNotSaveChanges
'--------------------------------------
'終了
'--------------------------------------
'終了時間
EndTime = Now()
'終了メッセージ
MsgBox FileCount & " ファイル結合しました。" & vbCrLf & vbCrLf & _
"出力先フォルダ：" & strOutputFolder & vbCrLf & _
"処理時間： " & Format(EndTime - StartTime, "hh:mm:ss"), _
vbOKOnly + vbInformation
'オブジェクトクリア
Set WSH = Nothing
Set FSO = Nothing
Set objFolder = Nothing
Set objFiles = Nothing
Set objF = Nothing
Set docWord1 = Nothing
Set docWord2 = Nothing
End Sub
