將工作表拆分爲單獨的工作簿

我有一張工作簿，其中包含用於學校成績單的工作表。我有一個應用於按鈕的宏，用於從主工作表導出信息，以便在同一工作簿中分離新生成的工作表。 A1：C71是模板並轉到每張新紙張，以下列信息（從D1：71到Q1：71）分別出現在單獨的紙張中（始終在D1：71中）。將工作表拆分爲單獨的工作簿

這裏的屏幕截圖（http://imgur.com/a/ZDOVb），而這裏的代碼：

`Option Explicit 

Sub parse_data() 
    Dim studsSht As Worksheet 
    Dim cell As Range 
    Dim stud As Variant 

    Set studsSht = Worksheets("Input") 
    With CreateObject("Scripting.Dictionary") 
     For Each cell In studsSht.Range("D7:Q7").SpecialCells(xlCellTypeConstants, xlTextValues) 
      .Item(cell.Value) = .Item(cell.Value) & cell.EntireColumn.Address(False, False) & "," 
     Next 
     For Each stud In .keys 
      Intersect(studsSht.UsedRange, studsSht.Range(Left(.Item(stud), Len(.Item(stud)) - 1))).Copy Destination:=GetSheet(CStr(stud)).Range("D1") 
     Next 
    End With 

    studsSht.Activate 
End Sub 

Function GetSheet(shtName As String) As Worksheet 
On Error Resume Next 
Set GetSheet = Worksheets(shtName) 
If GetSheet Is Nothing Then 
    Set GetSheet = Sheets.Add(after:=Worksheets(Worksheets.Count)) 
    GetSheet.Name = shtName 
    Sheets("Input").Range("A1:C71").Copy 
    GetSheet.Range("A1:D71").PasteSpecial xlAll 
    GetSheet.Range("A1:B71").EntireColumn.ColumnWidth = 17.57 
    GetSheet.Range("C1:C71").EntireColumn.ColumnWidth = 54.14 
    GetSheet.Range("D1:D71").EntireColumn.ColumnWidth = 22 
End If 
End Function`

現在我想建立一個單獨的按鈕分裂片成獨立的工作簿，使得主片可以保持的記錄保存並且可以在網上與父母分享個人工作簿（不會將任何孩子的信息泄露給他們自己以外的父母）。我希望將工作簿與工作表的現有名稱一起保存，並想知道是否有辦法將新工作簿自動保存在與原始工作簿相同的文件夾中，而無需輸入路徑名稱？（它不共享與任何表單相同的文件名）。

我試着找到其他代碼並修改它，但我只是得到單個空白工作簿，而且我需要生成的數量（最好是充滿了數據！），這取決於班級規模。這是可悲的嘗試：

`Sub split_Reports() 

Dim splitPath As String 

Dim w As Workbook 
Dim ws As Worksheet 

Dim i As Long, j As Long 
Dim lastr As Long 
Dim wbkName As String 
Dim wksName As String 

Set wsh = ThisWorkbook.Worksheets(1) 
splitPath = "G:\splitWb\" 
Set w = Workbooks.Add 

For i = 1 To lastr 
    wbkName = ws 
    w.Worksheets.Add(After:=w.Worksheets(Worksheets.Count)).Name = ws 
    w.SaveAs splitPath 
    w.Close 
    Set w = Workbooks.Add 
Next i 

End Sub`

我已經學到了很多，但我知道這麼少。

來源

2017-02-22 Davie

也許這會啓動你，只是一些簡單的代碼來保存每張表作爲一個新的工作簿。您可能需要檢查表格名稱是否爲有效的文件名稱。

Sub x() 

Dim ws As Worksheet 

For Each ws In ThisWorkbook.Sheets 
    ws.Copy 
    ActiveWorkbook.Close SaveChanges:=True, Filename:=ws.Name & ".xlsx" 
Next ws 

End Sub

來源

2017-02-22 21:05:39 SJR

這是理想的。謝謝。它會自動將它們保存到文檔中，這很好，因爲在幾臺不同的計算機上會有幾個不同的工作簿用戶，他們都會有這樣的文件夾。 – Davie

很高興工作。我認爲最好指定一條路徑。 – SJR

謝謝，是的，我同意。但老師們可能會在家裏或在城市的不同中心做他們的班級報告，我不能期望他們編輯這個模塊。 – Davie

將工作表拆分爲單獨的工作簿

回答

相關問題