Question

我需要Excel中的SaveAs宏来保存一个单元格中的多个文件。所以我有一个名为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

Answer 1

此代码应该适合您，希望评论足够解释

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

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

在excel中保存为宏

1 个答案: