批量移除文件夹中xlsm文件密码的VBA代码无报错但失效求助

核心问题1：Dir函数参数错误 #

原代码中Dir$(fpath & "*.xls" & vbNormal)的写法完全错误，vbNormal是文件属性参数，需作为Dir的第二个参数传入，而非拼接在文件名后。这种写法会让程序实际查找*.xls0（vbNormal的数值为0）格式的文件，根本匹配不到目标.xlsm文件，导致循环直接跳过。

同时，你要处理的是启用宏的.xlsm文件，通配符应改为*.xlsm，而非*.xls（后者匹配的是xls/xlsx等非宏文件）。

修正后的Dir调用：

strFilename = Dir$(fpath & "*.xlsm", vbNormal)

核心问题2：SaveAs未指定文件格式 #

保存.xlsm文件时必须明确指定宏启用的文件格式，否则Excel会默认保存为无宏的.xlsx格式，导致保存失败或文件损坏。需添加FileFormat:=xlOpenXMLWorkbookMacroEnabled参数（对应数值52）。

修正后的SaveAs代码：

xlBook.SaveAs Filename:=fpath & strFilename, _
              Password:="", _
              WriteResPassword:="", _
              FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
              CreateBackup:=True

其他优化点 #

• Application.DisplayAlerts可移至循环外统一设置，避免重复开关：

  Application.DisplayAlerts = False
  While Len(strFilename) <> 0
      ' 循环内代码
  Wend
  Application.DisplayAlerts = True
  

• 原代码中文件夹路径末尾的\已正确保留，无需调整。

完整修复后的代码 #

Sub RemovePasswords()
    Dim xlBook As Workbook
    Dim strFilename As String
    Dim strPassword As String
    Dim strEditPassword As String
    Dim fpath As String
    
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    fpath = "C:\Users\User525\Desktop\Test Group\"
    strFilename = Dir$(fpath & "*.xlsm", vbNormal)
    strPassword = "Password"
    strEditPassword = ""
    
    While Len(strFilename) <> 0
        Set xlBook = Workbooks.Open(Filename:=fpath & strFilename, _
                                    Password:=strPassword, _
                                    WriteResPassword:=strEditPassword)
        xlBook.SaveAs Filename:=fpath & strFilename, _
                      Password:="", _
                      WriteResPassword:="", _
                      FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
                      CreateBackup:=True
        xlBook.Close 0
        strFilename = Dir$()
    Wend
    
    Application.DisplayAlerts = True
    Application.EnableEvents = True
End Sub

内容的提问来源于stack exchange，提问作者bdough2