word合并文档，如何按文件名递增顺序合并？

sblisb

使用如下代码合并，有两个问题
1、怎么没有按文件名的顺序从大到小来合并呀？文件名为“表352100101”，表352100102....,如何按递增来合并每个文件？
2、每个文件合并时，每个文件要另起一页，文件尾如何插入一个分页符来分开另一个文件？
Sub HB()
Dim p$, f$, w As Object
    Application.Visible = False
    Set w = ActiveDocument
    p = w.Path & "\"
    Selection.WholeStory
    Selection.Delete Unit:=wdCharacter, Count:=1
    f = Dir(p & "*.doc")
    Do While f <> ""
        If f <> w.Name Then
            With Documents.Open(p & f)
                Selection.WholeStory
                Selection.Copy
                w.Activate
                Selection.PasteAndFormat (wdPasteDefault)
                .Close
            End With
        End If
        f = Dir
    Loop
    Application.Visible = True
End Sub
test.zip (56.26 KB, 下载次数: 11)

2019-4-10 11:05 上传

点击文件名下载附件

huanglicheng

供参考

sblisb

huanglicheng 发表于 2019-4-10 11:59
供参考

谢谢，代码怎么是图片呀，能提供文字版吗？

sblisb

Sub HBDoc()
Dim mDocument As Document
Dim NewDocument As Document
Dim mFile$, mPath$, Q%
'----------------------

Set mDocument = ActiveDocument
Application.Visible = False
mDocument.Content.Text = ""
mPath = mDocument.Path & "\"
'-------------------------

mFile = Dir(mPath & "*.doc")
    Do While mFile <> ""
        If mFile <> mDocument.Name Then
        Q = Q + 1
        Set NewDocument = Documents.Open(mPath & mFile)
        NewDocument.Content.Copy


         With mDocument
        .Activate
            If Q > 1 Then .Paragraphs.Last.Range.InsertBefore Chr(12)    '????????
            .Range(.Content.End - 1, .Content.End).Select
             Selection.PasteAndFormat (wdPasteDefault)
            End With
         NewDocument.Close
        End If
    mFile = Dir
    Loop
Application.Visible = True
End Sub

huanglicheng

sblisb 发表于 2019-4-10 14:23
谢谢，代码怎么是图片呀，能提供文字版吗？

写完了随手就关了忘记保存了。没有存根 不好意思了

sblisb

huanglicheng 发表于 2019-4-10 11:59
供参考

再次求助一下
文件名变成汉字在后数字在前，如35010403001（表）.docx,35010403003（表）.docx,
要按从大到小合并，如何改代码？

413191246se

楼主，请备份原文件后，试用下面的宏（合并后第1页的“分页符”请自行删除；合并后文档并未存盘，请自行保存/存盘；合并后请检查是否正确，不正确请等待各位高人相助。我不敢保证是否正确。双击文件夹直到进入最终所需要打开的文件夹后按确定）：

1. Sub test批量合并()
   
2. 'code by 捷克人
   
3.     On Error Resume Next
   
4.     Dim fd As FileDialog, p$, doc As Document, n&
   
5.     Set fd = Application.FileDialog(msoFileDialogFolderPicker)
   
6.     If fd.Show = -1 Then p = fd.SelectedItems(1) Else End
   
7.     Set fd = Nothing
   
8.     If MsgBox("是否处理文件夹 " & p & " ?", 4 + 48) = vbNo Then End
   
9.     Documents.Add
   
10.     Dim FileNameWithPath As Variant, ListOfFilenamesWithParh As New Collection
    
11.     Call FileSearchByHavrda(ListOfFilenamesWithParh, p, "*.docx", True)
    
12.     For Each FileNameWithPath In ListOfFilenamesWithParh
    
13.         Set doc = Documents.Open(FileName:=FileNameWithPath)
    
14.         With doc
    
15.                 .Content.Copy
    
16.                 .Close
    
17.                 With Selection
    
18.                     .EndKey 6
    
19.                     .InsertBreak Type:=wdPageBreak
    
20.                     .Paste
    
21.                 End With
    
22.                 ActiveDocument.Characters(1).Copy
    
23.         End With
    
24.         n = n + 1
    
25.     Next FileNameWithPath
    
26.     If ListOfFilenamesWithParh.Count = 0 Then MsgBox "File not found!"
    
27.     MsgBox "处理完毕！共处理 " & n & " 个文档！", 0 + 48
    
28. End Sub
    
29. Sub FileSearchByHavrda(pFoundFiles As Collection, pPath As String, pMask As String, pIncludeSubdirectories As Boolean)
    
30.     Dim DirFile As String, CollectionItem As Variant, SubDirCollection As New Collection
    
31.     pPath = Trim(pPath)
    
32.     If Right(pPath, 1) <> "" Then pPath = pPath & ""
    
33.     DirFile = Dir(pPath & pMask)
    
34.     Do While DirFile <> ""
    
35.         pFoundFiles.Add pPath & DirFile
    
36.         DirFile = Dir
    
37.     Loop
    
38.     If Not pIncludeSubdirectories Then Exit Sub
    
39.     DirFile = Dir(pPath & "*", vbDirectory)
    
40.     Do While DirFile <> ""
    
41.         If DirFile <> "." And DirFile <> ".." Then If ((GetAttr(pPath & DirFile) And vbDirectory) = 16) Then SubDirCollection.Add pPath & DirFile
    
42.         DirFile = Dir
    
43.     Loop
    
44.     For Each CollectionItem In SubDirCollection
    
45.          Call FileSearchByHavrda(pFoundFiles, CStr(CollectionItem), pMask, pIncludeSubdirectories)
    
46.     Next
    
47. End Sub

复制代码

sblisb

413191246se 发表于 2019-4-29 00:33
楼主，请备份原文件后，试用下面的宏（合并后第1页的“分页符”请自行删除；合并后文档并未存盘，请自行保 ...

谢谢！
选中指定文件夹，怎么提示File not found呀
扩展名为docx或doc都不行呀

sblisb

413191246se 发表于 2019-4-29 00:33
楼主，请备份原文件后，试用下面的宏（合并后第1页的“分页符”请自行删除；合并后文档并未存盘，请自行保 ...

请测试
合并word.zip (263.99 KB, 下载次数: 31)

2019-4-30 11:29 上传

点击文件名下载附件

添

sblisb

413191246se 发表于 2019-4-29 00:33
楼主，请备份原文件后，试用下面的宏（合并后第1页的“分页符”请自行删除；合并后文档并未存盘，请自行保 ...

发现是路径少了个/，添加后可以找到文件了
但运行后，宏是新建word文件，所以页面格式不一样，导致复制的文件和原来的页面不一样