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去掉可以正常打印，不过每一个都要手动选择路径保存