Разделение листов в отдельные рабочие книги

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