复制并另存为多张保持固定 Sheet VBA

Question

我有一个包含 15 张纸的工作簿，我想另存为新工作簿以保持 "Sheet1" 不变。

像这样，保存后我会得到包含以下表格的文件：

File 1: "Sheet1", "Sheet2"
File 2: "Sheet1", "Sheet3"
File 3: "Sheet1", "Sheet4"
File 4: "Sheet1", "Sheet5"

这是我目前得到的结果

Sub Splitbook()
Dim xPath As String
Dim xWs As Worksheet 
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If xWs.Name <> "Sheet1" Then
    For Each xWs In ThisWorkbook.Sheets(Array("Sheet1", xWs)).Copy
       Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
       Application.ActiveWorkbook.Close False
    Next
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

有人能帮帮我吗？

谢谢！

Answer 1

您可以尝试以下方法。在所有工作表的循环中，您排除了第一个。然后创建一个新工作簿并将所需的两个工作表复制到那里。循环删除新工作簿的空白表 - 这部分可能有一些更优雅的解决方案，但它有效。

Sub Splitbook()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim xWs As Worksheet
    Dim wb As Workbook
    For Each xWs In ThisWorkbook.Sheets
        If xWs.Name <> "Sheet1" Then
            Set wb = Workbooks.Add
            xWs.Copy before:=wb.Worksheets(1)
            ThisWorkbook.Sheets(1).Copy before:=wb.Worksheets(1)
            Do While wb.Worksheets.Count > 2
                wb.Worksheets(wb.Worksheets.Count).Delete
            Loop
            wb.SaveAs xWs.Name
            wb.Close
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

复制并另存为多张保持固定 Sheet VBA

Copy and Save As several sheets keeping fixed Sheet VBA

arrays

vba

loops

copy

dynamic