Question

我有一张带有学校成绩单主表的工作簿。我有一个宏应用于一个按钮，用于将信息从主工作表导出到同一工作簿中单独的，新生成的工作表。 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`

我学到了很多，但我知之甚少。

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

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

1 个答案: