将床单分成单独的工作簿

Question

我有一个带有学校成绩单的主表的工作簿。我有一个宏应用到一个按钮，以从主表中导出信息，以在同一工作簿中分离新生成的床单。A1：C71是模板，转到每张新表，以及以下信息列，从D1：71到Q1：Q1：71，每个信息都在单独的床单中（始终在D1：71中）。

这是屏幕截图（https://i.stack.imgur.com/4cwaf.jpg），这是代码：

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

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

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