批量合并（宏）for Word2003VBA

413191246se

* 请注意：如果文档要求按顺序打印，少量的话可以手动在文件名前加 1.2.3 等这样的序号，然后再合并。

1. Sub 批量合并()
   
2. '更新/2018-12-4/TEST-OK/彻底定稿！
   
3.     On Error Resume Next
   
4.     Dim fd As FileDialog, i&, doc As Document, p$, t&, j&, s As Section, k&, n&, m&, c&
   
5.     Set fd = Application.FileDialog(msoFileDialogFolderPicker)
   
6.     If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
   
7.     Set fd = Nothing
   
8.     If MsgBox("是否合并文件夹 " & p & " ?", 4 + 48) = vbNo Then End
   
9.     If MsgBox("<是>：Word 文档(*.doc)    <否>：文本文档(*.txt)", 4 + 48) = vbYes Then t = 0 Else t = 1
   
10.     If MsgBox("请选择分隔符！——<是>：分节符    <否>：分页符", 4 + 48) = vbYes Then j = 1 Else j = 0
    
11.     If j = 1 Then
    
12.         If MsgBox("每节页码！——<是>：重排    <否>：顺延", 4 + 48) = vbYes Then k = 1 Else k = 2
    
13.     Else
    
14.         k = 2
    
15.     End If
    
16.     Documents.Add
    
17.     With Application.FileSearch
    
18.         .NewSearch
    
19.         .LookIn = p
    
20.         .SearchSubFolders = True
    
21.         If t = 0 Then .FileName = "*.doc" Else .FileName = "*.txt"
    
22.         If .Execute > 0 Then
    
23.             For i = 1 To .FoundFiles.Count
    
24.                 If t = 0 Then
    
25.                     Set doc = Documents.Open(FileName:=.FoundFiles(i), Visible:=False)
    
26.                 Else
    
27.                     Set doc = Documents.Open(FileName:=.FoundFiles(i), Encoding:=936, Visible:=False)
    
28.                 End If
    
29.                 doc.Content.Copy
    
30.                 doc.Close
    
31.                 Selection.EndKey 6
    
32.                 Selection.Paste
    
33.                 ActiveDocument.Characters(1).Copy
    
34.                 If j = 1 Then
    
35.                     Selection.InsertBreak Type:=wdSectionBreakNextPage
    
36.                 Else
    
37.                     Selection.InsertBreak Type:=wdPageBreak
    
38.                 End If
    
39.             Next i
    
40.             MsgBox "合并完毕！共合并 " & .FoundFiles.Count & " 个文件！", 0 + 64
    
41.         Else
    
42.             MsgBox "未发现文件！", 0 + 16
    
43.         End If
    
44.     End With
    
45.     With ActiveDocument
    
46.         .Characters.Last.Previous.Delete
    
47.         .Characters.Last.Previous.Delete
    
48. '重排页码
    
49.         For Each s In .Sections
    
50.             s.Range.Select
    
51.             With Selection.Sections(1).Headers(1).PageNumbers
    
52.                 .NumberStyle = wdPageNumberStyleNumberInDash
    
53.                 If k = 1 Then .RestartNumberingAtSection = True Else .RestartNumberingAtSection = False
    
54.                 .StartingNumber = 1
    
55.             End With
    
56.             Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberCenter, FirstPage:=True
    
57.             ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
    
58.             Selection.HeaderFooter.LinkToPrevious = Not Selection.HeaderFooter.LinkToPrevious
    
59.             ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    
60.         Next
    
61.         Selection.HomeKey 6
    
62. '奇数加页
    
63.         Do
    
64.             For Each s In .Sections
    
65.                 n = s.Range.Information(3)
    
66.                 n = n - m
    
67.                 m = m + n
    
68.                 If n Mod 2 = 1 Then
    
69.                     s.Range.Characters.Last.InsertBreak Type:=wdPageBreak
    
70.                     n = 0
    
71.                     m = 0
    
72.                     c = 1
    
73.                     Exit For
    
74.                 Else
    
75.                     c = 0
    
76.                 End If
    
77.             Next
    
78.         Loop Until c = 0
    
79.     End With
    
80. End Sub

复制代码