• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Master workbook to Seperate Workbooks Macro Multiple sheets

xzcvb33

New Member
Hello, below is a macro that looks at a single sheet and parses it out to many sheets. This is a watered down version of what I need just so I could follow along & get a better understanding of writing macros so i just used the first sheet of my workbook I intend to use the macro on. The workbook has 4 more sheets. What is the best way of going about applying this to the other sheets in my workbook? Should I copy and paste this code 4 more times below & modify it to work with my other sheets? Is there a better approach? Also any other tips or advice is welcomed. I wasn't able to get the "save" part to work but I haven't spent as much time on that yet. The below code I wrote (followed along with a video & made some adjustments but I do mostly understand) but I did it based on the first tab of the attached file. It works now im not sure how to expend it to work for all the other tabs. Thanks for any help you can provide.

Code:
Sub CreateWBS()
Dim WBO As Workbook 'Master
Dim WBN As Workbook 'New
Dim WSO As Worksheet 'Original
Dim WSN As Worksheet 'New Worksheet

Set WBO = ActiveWorkbook
Set WSO = ActiveSheet

FinalRow = WSO.Cells(Rows.Count, 1).End(xlUp).Row + 1 'Find final Row


LastDept = Cells(4, 1)
StartRow = 4

For i = 4 To FinalRow
ThisDept = WSO.Cells(i, 1)
If ThisDept = LastDept Then 'Do nothing

Else
'We have a new dept starting
'Copy all of the previous rows to a new wkbk
LastRow = i - 1
RowCount = LastRow - StartRow + 1 'How many rows you want to copy

'Create a new workbook
Set WBN = Workbooks.Add(Template:=xlWBATWorksheet)
Set WSN = WBN.Worksheets(1)

'Set up headings
WSN.Cells(1, 1).Value = "Budget Summary"
WSN.Cells(2, 1).Value = LastDept & " - " & WSO.Cells(StartRow, 2)
WSO.Range("A3:K3").Copy Destination:=WSN.Cells(4, 1)



'Copy all records
WSO.Range(WSO.Cells(StartRow, 1), WSO.Cells(LastRow, 11)).Copy Destination:=WSN.Cells(5, 1)




'FN = LastDept & ".xlsx"
'FP = WBO & Application.PathSeparator

'WBN.SaveAs Filename:=FP & FN
'WBN.Close SaveChanges:=False

LastDept = ThisDept
StartRow = i
End If
Next i
End Sub
 

Attachments

  • Copy of sample1.xlsx
    69.9 KB · Views: 2
Back
Top