CODEWITHSUNDEEP
vbaexcel
Davie
Davie

Reputation: 7

Splitting Sheets into Separate Workbooks

I have a workbook with a master sheet for school report cards. I have a macro applied to a button for exporting information from the master sheet to separate, newly-generated sheets in the same workbook. A1:C71 is the template and goes to every new sheet, and the following columns of info, from D1:71 to Q1:71, each appear in separate sheets (always in D1:71).

Here's the screenshot (https://i.sstatic.net/4cWAF.jpg), and here's the code:

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

I would now like to create a separate button to split the sheets into separate workbooks so that the master sheet can be kept for record keeping and the individual workbooks can be shared with parents online (without divulging the info of any kid to parents other than their own). I would like the workbooks to be saved with the existing name of the sheet, and wonder if there's a way to have the new workbooks automatically saved in the same folder as the original workbook without having to input a path name? (It does not share the same filename as any of the sheets).

I tried finding other code and modifying it, but I just get single blank workbooks and I need as many as have been generated (preferably full of data!), which varies depending on the class size. Here's the pathetic attempt:

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

I have learned so much, and yet I know so little.

Upvotes: 0

Views: 183

Answers (1)

SJR
SJR

Reputation: 23081

Maybe this will start you off, just some simple code to save each sheet as a new workbook. You would probably need some check that the sheet name is a valid file name.

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

Upvotes: 1

Related Questions