请问如何批量保存多个word文档最后一页

和可

求助。在一个文件夹下有多个子文件夹，每个子文件夹中有多个word文档，想单独保存每个word文档的最后一页，并删除新文档的表头、页码，新文件名与原文件保持一致。目前有100多个word文档，手动一个一个处理想想就觉得累人。新人小白求助各位

gbgbxgb

1. Sub my_DelPagesSaveAs()
   
2.     Dim fs As Object, myPath$, thisDocumentName$
   
3.     Dim myDoc As Document, myDocName$, theSaveFormat&, i&
   
4.     '
   
5.     Set fs = CreateObject("Scripting.FileSystemObject")
   
6.     thisDocumentName = fs.getfilename(ThisDocument.FullName)
   
7.     myPath = ThisDocument.Path
   
8.     If Right(myPath, 1) <> "" Then myPath = myPath & ""
   
9.     '
   
10.     myDocName = Dir(myPath & "*.doc", vbDirectory)
    
11.     Do While myDocName <> ""
    
12.         If (GetAttr(myPath & myDocName) And vbDirectory) = 0 Then
    
13.             If myDocName <> thisDocumentName Then
    
14.                 Set myDoc = Documents.Open(myPath & myDocName)
    
15.                 With myDoc
    
16.                     i = .ActiveWindow.Panes(1).Pages.Count
    
17.                     If i > 1 Then
    
18.                         i = .ActiveWindow.Panes(1).Pages(i).Breaks(1).Range.Start
    
19.                         On Error Resume Next
    
20.                         .Range(0, i).Delete
    
21.                         If Err <> 0 Then
    
22.                             On Error GoTo 0
    
23.                             MsgBox "当前文档“" & myDocName & "”无法删除页！", vbExclamation, "错误"
    
24.                             DoEvents
    
25.                             .Close False
    
26.                         Else
    
27.                             On Error GoTo 0
    
28.                             theSaveFormat = .SaveFormat
    
29.                             .SaveAs FileName:=myPath & myDocName, fileformat:=theSaveFormat
    
30.                             .Close False
    
31.                         End If
    
32.                     Else
    
33.                         .Close False
    
34.                     End If
    
35.                 End With
    
36.             End If
    
37.         End If
    
38.         myDocName = Dir
    
39.     Loop
    
40.     Set fs = Nothing
    
41.     Set myDoc = Nothing
    
42. End Sub

复制代码

和可

感谢回复，但是代码运行后没反应，不知道是不是我操作有问题，我上传了附件，麻烦再帮忙调试一下，感谢，感谢！

gbgbxgb

和可 发表于 2022-3-4 11:27
感谢回复，但是代码运行后没反应，不知道是不是我操作有问题，我上传了附件，麻烦再帮忙调试一下，感 ...

前粘贴的代码句（第8行）：
If Right(myPath, 1) <> "" Then myPath = myPath & ""
漏了斜杠，即你可修改如下再试试：
If Right(myPath, 1) <> "" Then myPath = myPath & "\"

另：删除页脚（亦或页眉？）的代码未写（因你当初未提供附件，不明确你的页眉或页脚情况）。

gbgbxgb

发现使用网站提供的“粘贴代码”功能，粘贴代码后，有些字符缺失，现重新粘贴文本代码如下：
Sub my_DelPagesSaveAs()
    Dim fs As Object, myPath$, thisDocumentName$, i&
    Dim myDoc As Document, myDocName$, theSaveFormat&
    '
    Set fs = CreateObject("Scripting.FileSystemObject")
    thisDocumentName = fs.getfilename(ThisDocument.FullName)
    myPath = ThisDocument.Path
    If Right(myPath, 1) <> "" Then myPath = myPath & "\"
    '
    myDocName = Dir(myPath & "*.doc", vbDirectory)
    Do While myDocName <> ""
        If (GetAttr(myPath & myDocName) And vbDirectory) = 0 Then
            If myDocName <> thisDocumentName Then
                Set myDoc = Documents.Open(myPath & myDocName)
                With myDoc
                    i = .ActiveWindow.Panes(1).Pages.Count
                    If i > 1 Then
                        i = .ActiveWindow.Panes(1).Pages(i).Breaks(1).Range.Start
                        On Error Resume Next
                        .Range(0, i).Delete
                        If Err <> 0 Then
                            On Error GoTo 0
                            MsgBox "当前文档“" & myDocName & "”无法删除页！", vbExclamation, "错误"
                            DoEvents
                            .Close False
                        Else
                            On Error GoTo 0
                            .Sections(1).Footers(wdHeaderFooterPrimary).Range.Delete
                            theSaveFormat = .SaveFormat
                            .SaveAs FileName:=myPath & myDocName, fileformat:=theSaveFormat
                            .Close False
                        End If
                    Else
                        .Close False
                    End If
                End With
            End If
        End If
        myDocName = Dir
    Loop
The_Exit:
    Set fs = Nothing
    Set myDoc = Nothing
End Sub

和可

gbgbxgb 发表于 2022-3-4 18:22
发现使用网站提供的“粘贴代码”功能，粘贴代码后，有些字符缺失，现重新粘贴文本代码如下：
Sub my_DelPa ...

太厉害了，运行完美，十分感谢！