Vba 将工作表拆分为单独的工作簿

我有一本附有学校成绩单的工作手册。我在一个按钮上应用了一个宏，用于将信息从主工作表导出到同一工作簿中新生成的单独工作表。A1:C71是模板，用于每个新工作表，以下信息列（从D1:71到Q1:71）分别出现在单独的工作表中（始终在D1:71中）

这是屏幕截图（），这是代码：

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

---

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

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

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

---

这是理想的。非常感谢。它会自动将它们保存到文档中，这很好，因为在不同的计算机上会有多个工作簿的不同用户，而且他们都会有这样一个文件夹。很高兴它起作用了。我想说指定路径也是更好的做法。谢谢，是的，我同意。但是老师们可能会在家里，或者在城市的不同中心做课堂报告，我不能期望他们编辑模块。