Split workbook

  • Thread starter Thread starter Cheryl
  • Start date Start date
C

Cheryl

MS Office 2000, Windows 2000

Able to split the workbook so each sheet creates a new
workbook with the following macro.

Public Sub SpitWorkbook()
Dim W As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each W In Worksheets
ActiveSheet.Copy
Cells.Copy
Cells.PasteSpecial xlPasteValues
Cells(1).Select
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path
& "/" & W.Name
ActiveWorkbook.Close
Next W

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

However, as each sheet represents an employee I need the
employees that report to the same manager copied to the
same workbook.
 
Assume the managers name is in Cell B2 of each sheet

Option Explicit
Public Sub SpitWorkbook()
Dim W As Worksheet
Dim bk As Workbook
Dim sCheryl As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each W In Worksheets
sCheryl = W.Range("B2").Value
Set bk = Nothing
On Error Resume Next
Set bk = Workbooks(sCheryl)
On Error GoTo 0
If bk Is Nothing Then
ActiveSheet.Copy
Cells.Copy
Cells.PasteSpecial xlPasteValues
Cells(1).Select
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
ThisWorkbook.Path & "\" & sCheryl & ".xls"
Else
ActiveSheet.Copy After:=bk.Worksheets( _
bk.Worksheets.Count)
Cells.Copy
Cells.PasteSpecial xlPasteValues
Cells(1).Select
bk.Save
End If
Next W
For Each bk In Application.Workbooks
If bk.Name <> ThisWorkbook.Name Then
bk.Close Savechanges:=False
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Code is untested, but should be work.
 
Back
Top