宏 VBA，无法让“SaveAs”发挥作用

Posted 2023-05-07

【中文标题】宏 VBA，无法让“SaveAs”发挥作用

【英文标题】：Macro VBA, can't get "SaveAs" to function

【发布时间】：2021-06-29 19:36:20

【问题描述】：

我有一个在工作簿集上运行的流程。我试图在关闭文件时修改文件类型。在关闭每个工作簿之前，我正在尝试将其添加到流程的末尾。现在，打开的文件位于 .xlsb 中。我正在尝试将其保存为基本上任何其他格式（.xsls 等）

每当我运行宏时，“SaveAs”命令都会出错。我已经尝试了所有我能想到的方法，只是用相同的名称、不同的文件类型保存文件，但没有运气。

我做错了什么？

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Path = ThisWorkbook.Sheets(1).Range("H6")

If Right(Path, 1) <> "\" Then
    Path = Path & "\"
End If


wsheet = ThisWorkbook.Sheets(1).Range("F10")

ThisWorkbook.Sheets(3).Range("A2:B20000").ClearContents
OutLn = 2
Line = 1

Do While ThisWorkbook.Sheets(2).Cells(Line, 1) <> ""
    OpnFil = ThisWorkbook.Sheets(2).Cells(Line, 1)
    Workbooks.Open fileName:=Path & OpnFil, UpdateLinks:=False
    ScanLn = 12
        Do While ThisWorkbook.Sheets(1).Cells(ScanLn, 5) <> ""
            ThisWorkbook.Sheets(3).Cells(OutLn, 1) = OpnFil
            Addr = ThisWorkbook.Sheets(1).Cells(ScanLn, 5)
            ThisWorkbook.Sheets(3).Cells(OutLn, 2) = Workbooks(OpnFil).Sheets(wsheet).Range(Addr)
            OutLn = OutLn + 1
            ScanLn = ScanLn + 1
        Loop
    Workbooks(OpnFil).SaveAs fileName:=Workbooks(OpnFil).GetBaseName, FileFormat:=51
    Workbooks(OpnFil).Close
    Line = Line + 1
Loop

End Sub```

【问题讨论】：

Workbook 没有 GetBaseName 方法。 GetBaseName 是 FileSystemObject 的一个方法。

不，也许这是我的问题。我希望它会保存到它从（路径）打开的具有相同文件名的相同扩展名中。

我也试过这个Workbooks(OpnFil).SaveAs fileName:=Workbooks(OpnFil).Name, FileFormat:=51 和其他大约一百个哈哈。

请记住，FileFormat 必须与扩展名匹配，否则您会收到错误消息。

好的，很高兴知道，正在打开的文件是 .xlsb。我要添加的部分内容是将其保存为另一个文件路径 .xls/.xlsx。我想我可以通过添加 FileFormat 值来做到这一点。

【参考方案1】：

备份工作簿

使用变量来避免（长）不可读的行（参数）。

Option Explicit

Sub BackupWorkbooks()
    
    Dim swb As Workbook: Set swb = ThisWorkbook
    
    Dim dFolderPath As String: dFolderPath = swb.Sheets(1).Range("H6").Value
    If Right(dFolderPath, 1) <> "\" Then
        dFolderPath = dFolderPath & "\"
    End If
    
    Dim dwsName As String: dwsName = swb.Sheets(1).Range("F10").Value
    
    Application.ScreenUpdating = False
    
    swb.Sheets(3).Range("A2:B" & swb.Sheets(3).Rows.Count).ClearContents
    
    Dim OutLn As Long: OutLn = 2
    Dim Line As Long: Line = 1
    
    Dim dwb As Workbook
    Dim dOldName As String
    Dim dOldPath As String
    Dim dNewPath As String
    Dim dAddr As String
    Dim ScanLn As Long
    
    Do While swb.Sheets(2).Cells(Line, 1) <> ""
        
        dOldName = swb.Sheets(2).Cells(Line, 1)
        dOldPath = dFolderPath & dOldName
        Set dwb = Workbooks.Open(Filename:=dOldPath, UpdateLinks:=False)
        
        ScanLn = 12
        Do While swb.Sheets(1).Cells(ScanLn, 5).Value <> ""
            swb.Sheets(3).Cells(OutLn, 1).Value = dOldName
            dAddr = swb.Sheets(1).Cells(ScanLn, 5).Value
            swb.Sheets(3).Cells(OutLn, 2).Value _
                = dwb.Worksheets(dwsName).Range(dAddr).Value
            OutLn = OutLn + 1
            ScanLn = ScanLn + 1
        Loop
        
        dNewPath = Left(dOldPath, InStrRev(dOldPath, ".") - 1) & ".xlsx"
        ' Or if you insist:
        'dNewPath =  dFolderPath & CreateObject("Scripting.FileSystemObject") _
            .GetBaseName(dOldName) & ".xlsx"
        
        Application.DisplayAlerts = False
        dwb.SaveAs Filename:=dNewPath, FileFormat:=xlOpenXMLWorkbook ' 51
        Application.DisplayAlerts = True
        dwb.Close
        
        Line = Line + 1
    
    Loop

    Application.ScreenUpdating = True
    
    MsgBox "Backups created.", vbInformation, "Backup Workbooks"

End Sub

【讨论】：

非常有帮助，谢谢。我也会研究这个以提高其他效率。谢谢！