Sub 宏1()
'
' 宏1 宏
'
'
    Dim path As String
    path = "F:\一户一档\"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.getfolder(path)
    Set sfs = f.SubFolders
    For Each sf In sfs
        ChangeFileOpenDirectory (sf)
        Documents.Open FileName:="01不动产登记申请书.doc", ConfirmConversions:=False, _
        ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
        PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
        WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""
        Application.PrintOut Background:=False, Append:=False, Range:=wdPrintAllDocument, OutputFileName:=sf & "\01不动产登记申请书.pdf", Copies:=1, PageType:=wdPrintAllPages, PrintTOFile:=True, Collate:=True, ManualDuplexPrint:=False
        ActiveWindow.Close
        Documents.Open FileName:="03不动产权籍调查表.doc", ConfirmConversions:=False, _
        ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
        PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
        WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""
        Application.PrintOut Background:=False, Append:=False, Range:=wdPrintAllDocument, OutputFileName:=sf & "\03不动产权籍调查表.pdf", Copies:=1, PageType:=wdPrintAllPages, PrintTOFile:=True, Collate:=True, ManualDuplexPrint:=False
        ActiveWindow.Close
    Next
End Sub

把OutputFileName:=sf & "\01不动产登记申请书.pdf", PrintTOFile:=True去掉可以正常打印，不过每一个都要手动选择路径保存

可以给你参考一下我的代码:
遍历某文件夹,并将其下所有的 Word文档另存为PDF

Sub Traver_Folder_Save2PDF()
'遍历某文件夹及其下一级子文件夹下文件(非递归方法)
'并将所有Word文档另存为PDF
'Code by:厨师王德榜  2021.6.28
    Dim cPath As String, subPath As String, subFile
    cPath = "c:\XIDE\Plugins\"
    cPath = IIf(Right(cPath, 1) <> "\", cPath & "\", cPath)
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder0 = FSO.getfolder(cPath)
    '遍历自身拥有的文件
    If Folder0.Files.Count > 0 Then
        For Each subFile In Folder0.Files
            subFile = (subFile.Name)
            If InStr(1, LCase(subFile), ".doc", vbTextCompare) > 0 Then Save_as_PDF cPath, subFile
        Next subFile
    End If
    
    If Folder0.subfolders.Count > 0 Then
    Set sfs = Folder0.subfolders
    For Each sf In sfs  '遍历下一级拥有的文件
        subPath = sf.path
        subPath = IIf(Right(subPath, 1) <> "\", subPath & "\", subPath)
      If sf.Files.Count > 0 Then

        For Each subFile In sf.Files
            subFile = (subFile.Name)
            If InStr(1, LCase(subFile), ".doc", vbTextCompare) > 0 Then Save_as_PDF subPath, subFile
        Next subFile

      End If
    Next
    End If
End Sub

Public Sub Save_as_PDF(ByVal paraPath As String, ByVal paraFile As String)
Dim cFout As String, ii As Integer
Dim oleDoc As Object
ii = InStr(1, LCase(paraFile), ".doc", vbTextCompare)
cFout = Left(paraFile, ii - 1) + ".pdf"
cFout = paraPath & cFout
If Len(Dir(paraPath)) > 0 Then
    ChangeFileOpenDirectory (paraPath)
    
   If Len(Dir(paraPath & paraFile)) > 0 Then
     Set oleDoc = Documents.Open(FileName:=paraFile, _
        ConfirmConversions:=False, _
        ReadOnly:=False, _
        AddToRecentFiles:=False, _
        PasswordDocument:="", _
        PasswordTemplate:="", _
        Revert:=False, _
        WritePasswordDocument:="", _
        WritePasswordTemplate:="", _
        Format:=wdOpenFormatAuto, _
        XMLTransform:="")
        
      oleDoc.Activate
      If Len(Dir(cFout)) > 0 Then Kill cFout
    
    oleDoc.ExportAsFixedFormat _
        OutputFileName:=cFout, _
        ExportFormat:=wdExportFormatPDF, _
        OpenAfterExport:=False, _
        OptimizeFor:= _
        wdExportOptimizeForPrint, _
        Range:=wdExportAllDocument, _
        From:=1, To:=1, _
        Item:=wdExportDocumentContent, _
        IncludeDocProps:=True, _
        KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, _
        DocStructureTags:=True, _
        BitmapMissingFonts:=True, _
        UseISO19005_1:=False
        
        oleDoc.Saved = True
        oleDoc.Close
        Set oleDoc = Nothing
    End If
End If
End Sub