如何将工作簿中的多个选项卡保存到新工作簿并使用新名称保存并断开链接

Question

这一切都是新的！请帮忙，当我运行这个宏时，它会通过，但它会打开一个新的工作簿，其中包含我需要的选项卡，但没有重命名它或将其保存到我需要的目标文件夹中？运行时弹出424错误。另外，我可以在末尾添加一段代码来断开它来自的工作簿的链接吗？

Option Explicit

Sub Copysheetandsave()
    Dim sourceWs As Worksheet, savePath As String

    Set sourceWs = ThisWorkbook.Worksheets(Array("S&M", "400", "410")).Copy

    savePath = "C:\Users\"

    sourceWs.Copy
    With ActiveWorkbook
        .SaveAs Filename:=savePath & "YTD 2023 YTD.xlsx"
         .Close False
    End With

End Sub

Answer 1

导出表格并断开链接

主要

Sub ExportSheetsToNewWorkbook()
    Const PROC_TITLE As String = "Export Sheets To New Workbook"
    Dim Success As Boolean
    On Error GoTo ClearError
    
    Const DST_PATH As String = "C:\Test\T2024\77951414\" ' "C:\Users\"
    Const DST_NAME As String = "YTD 2023 YTD.xlsx"
    Const DST_FORMAT As Long = xlOpenXMLWorkbook ' 51
    Dim sSheetNames() As Variant: sSheetNames = Array("S&M", "400", "410")
    
    ' Build the destination file path.
    Dim pSep As String: pSep = Application.PathSeparator
    Dim dFolderPath As String: dFolderPath = DST_PATH
    If Right(dFolderPath, 1) <> pSep Then dFolderPath = dFolderPath & pSep
    Dim dFilePath As String: dFilePath = dFolderPath & DST_NAME
    
    ' Copy the source sheets to a new workbook, the destination workbook.
    Dim wbLinked As Workbook: Set wbLinked = ThisWorkbook ' workbook containing this code
    Dim sshs As Sheets: Set sshs = wbLinked.Sheets(sSheetNames)
    Application.ScreenUpdating = False
    sshs.Copy
    
    ' Reference the destination workbook.
    Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
    ' Break all links to the source workbook.
    BreakLinksToAnotherWorkbook wbLinked, dwb
    
    ' Save the destination workbook.
    Application.DisplayAlerts = False ' overwrite without confirmation
    dwb.SaveAs Filename:=dFilePath, FileFormat:=DST_FORMAT
    
    Success = True
    
ProcExit:
    On Error Resume Next ' prevent endless loop if error in continuation
        Application.DisplayAlerts = True
        ' Close the destination workbook.
        If Not dwb Is Nothing Then dwb.Close SaveChanges:=False
        Application.ScreenUpdating = True
        ' Inform.
        If Success Then MsgBox "Sheets exported.", vbInformation, PROC_TITLE
    On Error GoTo 0
    Exit Sub
ClearError:
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Sub

帮助 - 断开另一个工作簿的链接

Sub BreakLinksToAnotherWorkbook( _
        ByVal wb As Workbook, _
        ByVal wbLinked As Workbook)
    Const PROC_TITLE As String = "Break Links to Another Workbook"
    
    Dim LinkNames As Variant: LinkNames = wb.LinkSources(xlExcelLinks)
    If IsEmpty(LinkNames) Then Exit Sub
    
    Dim LinkedFilePath As String: LinkedFilePath = wbLinked.FullName
    
    Dim n As Long, i As Long, ErrNumber As Long
    
    For n = 1 To UBound(LinkNames)
        If StrComp(LinkNames(n), LinkedFilePath, vbTextCompare) = 0 Then
            On Error Resume Next
                wb.BreakLink LinkNames(n), xlLinkTypeExcelLinks
                ErrNumber = Err.Number
            On Error GoTo 0
            If ErrNumber <> 0 Then
                MsgBox "Could not break the links to """ & LinkedFilePath _
                    & """!", vbExclamation, PROC_TITLE
            End If
            Exit Sub
        End If
    Next n
        
End Sub

奖励 - 断开 Excel 链接（未使用）

Sub BreakExcelLinks(ByVal wb As Workbook)
    Const PROC_TITLE As String = "Break Excel Links"
    
    Dim LinkNames As Variant: LinkNames = wb.LinkSources(xlExcelLinks)
    If IsEmpty(LinkNames) Then Exit Sub
    
    Dim n As Long, i As Long, ErrNumber As Long
    
    For n = 1 To UBound(LinkNames)
        On Error Resume Next
            wb.BreakLink LinkNames(n), xlLinkTypeExcelLinks
            ErrNumber = Err.Number
        On Error GoTo 0
        If ErrNumber <> 0 Then
            i = i + 1
            LinkNames(i) = LinkNames(n)
        End If
    Next n
    
    If i = 0 Then Exit Sub
    If i < n - 1 Then ReDim Preserve LinkNames(1 To i)
    
    MsgBox "Could not break the links to the following files:" _
        & vbLf & vbLf & Join(LinkNames, vbLf), vbExclamation, PROC_TITLE
        
End Sub