将工作表分成单独的工作簿

我有一本工作手册，上面有一张学校成绩单的工作表。 我有一个应用于button的macros，用于从主工作表中导出信息，以在同一工作簿中分离新生成的工作表。 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` 

现在我想创build一个单独的button来将工作表分成单独的工作簿，以便可以保留主工作表用于保存logging，并且可以将每个工作簿与父母在线共享（而不会将任何孩子的信息泄露给其他父母拥有）。 我希望将工作簿保存为工作表的现有名称，并想知道是否有办法将新工作簿自动保存在与原始工作簿相同的文件夹中，而无需inputpath名称？ （它不共享与任何表单相同的文件名）。

我试图find其他的代码并修改它，但是我得到了单个空白的工作簿，而且我需要生成的数据（最好是完整的数据！），这取决于类的大小。 这是可悲的尝试：

 `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` 

我学到了很多东西，但是我知道的很less。

Answer 1

也许这会启动你，只是一些简单的代码来保存每张表作为一个新的工作簿。 您可能需要检查工作表名称是否是有效的文件名。

 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