在excel中另存为宏

Posted 2023-05-07

【中文标题】在excel中另存为宏

【英文标题】：save as macro in excel

【发布时间】：2014-12-17 11:51:45

【问题描述】：

我需要 Excel 中的另存为宏来保存一个单元格中的多个文件。 所以我有一个名为 X 的 Excel 文件。在该文件中，我有 5 张工作表需要保存在另一个目的地，我还有一个分发表，我想在其中将宏附加到按钮以将文件保存到合适的位置。

在我的分发列表中，我有一个单元格，其中包含需要保存 5 张工作表的位置。我希望能够只编辑该单元格并按宏按钮另存为。 例如，如果我想保存工作表 AAA。 单元格 B3 “H:\Test\Saveasfolder\AAA（工作表名称）” - 编辑它然后按宏另存为。

Sub sb_Copy_Save_ActiveSheet_As_Workbook()
    Set wb = Workbooks.Add
    ThisWorkbook.Activate
    ActiveSheet.Copy
    Before:=wb.Sheets(1)
    wb.Activate
    wb.SaveAs "H:\Transaction Listing\Cluster 1\test3.xlsx"
End Sub

【问题讨论】：

您自己尝试过吗？有什么代码可以分享吗？

是的，我试过了，如下：

Sub sb_Copy_Save_ActiveSheet_As_Workbook() 设置 wb = Workbooks.Add ThisWorkbook.Activate ActiveSheet.Copy Before:=wb.Sheets(1) wb.Activate wb.SaveAs "H:\Transaction Listing\Cluster 1\test3 .xlsx" 结束子

问题是它没有与单元格链接，我每次在 vba 上都必须手动更改目的地。

【参考方案1】：

这段代码应该对你有用，希望 cmets 足够解释

Sub MySaveAs()

Dim FName As String
Dim FPath As String
Dim NewWS As Workbook
Dim MySheets As Worksheet
Dim FileExtStr As String

    'Turn screen updating off to prevent flicker
    Application.ScreenUpdating = False

    FPath = ActiveCell.Value
    For Each MySheets In ActiveWorkbook.Worksheets
        Select Case MySheets.Name
            Case "AAA", "BBB", "CCC", "DDD", "EEE" 'will only do this for these sheet names, edit as required
                'Find out the file format to use based on current workbook
                If Val(Application.Version) < 12 Then
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    Select Case ThisWorkbook.FileFormat
                        Case 51, 52
                            FileExtStr = ".xlsx"
                            FileFormatNum = 51
                        Case 56:
                            FileExtStr = ".xls"
                            FileFormatNum = 56
                        Case Else:
                            FileExtStr = ".xlsb"
                            FileFormatNum = 50
                    End Select
                End If
                'set the file name
                FName = MySheets.Name & FileExtStr
                'Check if file alredy exists at the location
                If Dir(FPath & "\" & FName) <> "" Then
                    MsgBox "File " & FPath & "\" & FName & " already exists"
                Else
                    'create new workbook
                    Set NewWS = Workbooks.Add
                    'copy existing sheet
                    MySheets.Copy Before:=NewWS.Sheets(1)
                    'switch off alerts so no confirmation prompt is displayed
                    Application.DisplayAlerts = False
                    'switch off error handing just in case sheet doesnt exist whilst trying to delete it
                    On Error Resume Next
                    'Delete the default "Sheet1"
                    NewWS.Worksheets("Sheet1").Delete
                    'Switch error handling and alerts back on
                    Application.DisplayAlerts = True
                    On Error GoTo 0
                    'Save file using path from cell and current sheet name
                    NewWS.SaveAs Filename:=FPath & "\" & FName
                    'close the file
                    NewWS.Close
                End If
            Case Else
        End Select
    Next MySheets

    'Turn screen updating back on
    Application.ScreenUpdating = True

End Sub

当前单元格没有真正的验证来检查它是否是有效的文件夹路径，将留给你

【讨论】：

非常感谢！像魅力一样工作！非常感谢！