別々のワークブックにシートを分割する

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` 

私は今、マスターシートは記録保持のために保つことができるように、別々のワークブックにシートを分割するために別のボタンを作成したいです個々のワークブックをオンラインで保護者と共有することができます（子供の情報を自分以外の保護者に漏らすことなく）。ブックの既存の名前でワークブックを保存し、新しいワークブックをパス名を入力せずにオリジナルのブックと同じフォルダに自動的に保存する方法があるのだろうかと思います。 （これは、いずれのシートとも同じファイル名を共有しません）。

他のコードを探して修正しようとしましたが、空白のワークブックが1つしかなく、生成されたものが必要です（データがいっぱいであることが必要です）。クラスのサイズによって異なります。哀れな試みは次のとおりです。

`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