將Excel工作表拆分爲多個工作簿

Question

我有一個包含多個工作表的Excel文件。我想將它分成單獨的文件，每個文件3張。

我創建了一個新的工作簿，如下所示：

Set NewBook = Workbooks.Add 
With NewBook 
    .Title = "File1" 
    .Subject = "File1" 
    .SaveAs FileName:="File1.xls" 
End With 

我如何複製表從一個到另一個？

Answer 1

此代碼將

• 分裂您一次工作簿到3張批新的工作簿，
• 其保存爲下面
• 命名新文件，關閉它們

File1（前3張）
File4（表4-6）
File7（sheets 7-9）

代碼將用附加工作表「填充」Excel文件以保留3頁拆分多個部分。

注意，您可以創建一個使用.Copy一個新的工作簿 - 無需使用Workbooks.Add

Code to be run from the Workbook to be split

Sub BatchThree() 
    Dim lngSht As Long 
    Dim lngShtAdd As Long 
    Dim lngShts As Long 
    Dim bSht As Boolean 
    With Application 
     .ScreenUpdating = False 
     .EnableEvents = False 
     .DisplayAlerts = False 
    End With 
    lngSht = 1 

    'pad extra sheets 
    If ThisWorkbook.Sheets.Count Mod 3 <> 0 Then 
     bSht = True 
     lngShts = ThisWorkbook.Sheets.Count Mod 3 
     For lngShtAdd = 3 To (lngShts + 1) Step -1 
      ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(Sheets.Count) 
     Next 
    End If 

    Do While lngSht + 2 <= ThisWorkbook.Sheets.Count 
     Sheets(Array(lngSht, lngSht + 1, lngSht + 2)).Copy 
     ActiveWorkbook.SaveAs ThisWorkbook.Path & "/File" & lngSht 
     ActiveWorkbook.Close False 
     lngSht = lngSht + 3 
    Loop 

    'remove extra sheets 
    If bSht Then 
    For lngShtAdd = 3 To (lngShts + 1) Step -1 
      ThisWorkbook.Sheets(Sheets.Count).Delete 
     Next 
    End If 

    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
     .DisplayAlerts = True 
    End With 
End Sub 

Answer 2

的基本語法，使複印件（如果那是你的問題）：

Sub Make_Copy() 
Thisworkbook.Sheets(1).Copy _ 
    after:=SomeWorkbook.Sheets(1) 
End Sub 

接下來複制，自然也可以移動表。您可以在之前而不是之後複製並更改工作表的名稱。