Split a worksheet to separate workbooks by column using VBA in Excel 365

[jvdm]

Hi there,
I have situation that requires me to split salary data per department so that each manager will receive a workbook for their team only. I do not mail these out to managers, I simply safe it in their respective folder on the server.

I use this code, but this code does not split the worksheet into separate files. Can you please help me to modify this code so that it will create separate workbooks for me in the same directory as the master sheet?

Sub SplitIntoSheets()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
ThisWorkbook.Activate
Sheet1.Activate
'clearing filter if any
On Error Resume Next
Sheet1.ShowAllData
On Error GoTo 0
Dim lsrClm As Long
Dim lstRow As Long
'counting last used row
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim Planners As Range
Dim clm As String, clmNo As Long
On Error GoTo handler
clm = Application.InputBox("From which column you want create files" & vbCrLf & "E.g. A,B,C,AB,ZA etc.")
clmNo = Range(clm & "1").Column
Set Planners = Range(clm & "2:" & clm & lstRow)
'Calling Remove Duplicates to Get Unique Names
Set Planners = RemoveDuplicates(Planners)
Call CreateSheets(Planners, clmNo)
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
.Calculation = xlCalculationAutomatic
End With
Sheet1.Activate
MsgBox "Well Done!"
Exit Sub
Data.ShowAllData
handler:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function RemoveDuplicates(Planners As Range) As Range
ThisWorkbook.Activate
Sheets.Add
On Error Resume Next
ActiveSheet.Name = "Planners"
Sheets("Planners").Activate
On Error GoTo 0
Planners.Copy
Cells(2, 1).Activate
ActiveCell.PasteSpecial xlPasteValues
Range("A1").Value = "Planners"
Dim lstRow As Long
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:A" & lstRow).Select
ActiveSheet.Range(Selection.Address).RemoveDuplicates Columns:=1, Header:=xlNo
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Set RemoveDuplicates = Range("A2:A" & lstRow)
End Function
Sub CreateSheets(Planners As Range, clmNo As Long)
Dim lstClm As Long
Dim lstRow As Long

For Each Unique In Planners
Sheet1.Activate
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
Dim dataSet As Range
Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
dataSet.AutoFilter field:=clmNo, Criteria1:=Unique.Value
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
Debug.Print lstRow; lstClm
Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
dataSet.Copy
Sheets.Add
ActiveSheet.Name = Unique.Value2
ActiveCell.PasteSpecial xlPasteAll
Next Unique
End Sub

 

[DanteAmor]

Try this. Sheet1 is filtered by column A. The books are saved with the name of the cell value.

Sub SplitIntoBooks()
  Dim wb As Workbook, c As Range, ky As Variant
  Dim lr As Long, lc As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Sheet1.Range("A1").AutoFilter
  lr = Sheet1.Range("A" & Rows.Count).End(3).Row
  lc = Sheet1.Cells(1, Columns.Count).End(1).Column
  With CreateObject("scripting.dictionary")
    For Each c In Sheet1.Range("A2:A" & lr)
      .Item(c.Value) = Empty
    Next
    For Each ky In .Keys
      Sheet1.Range("A1", Sheet1.Cells(lr, lc)).AutoFilter 1, ky
      Set wb = Workbooks.Add(xlWBATWorksheet)
      Sheet1.AutoFilter.Range.Copy Range("A1")
      wb.SaveAs ThisWorkbook.Path & "\" & ky
      wb.Close False
    Next
  End With
  
  Sheet1.ShowAllData
  Application.ScreenUpdating = True
End Sub

 

[jvdm]

Try this. Sheet1 is filtered by column A. The books are saved with the name of the cell value.

Sub SplitIntoBooks()
  Dim wb As Workbook, c As Range, ky As Variant
  Dim lr As Long, lc As Long
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Sheet1.Range("A1").AutoFilter
  lr = Sheet1.Range("A" & Rows.Count).End(3).Row
  lc = Sheet1.Cells(1, Columns.Count).End(1).Column
  With CreateObject("scripting.dictionary")
    For Each c In Sheet1.Range("A2:A" & lr)
      .Item(c.Value) = Empty
    Next
    For Each ky In .Keys
      Sheet1.Range("A1", Sheet1.Cells(lr, lc)).AutoFilter 1, ky
      Set wb = Workbooks.Add(xlWBATWorksheet)
      Sheet1.AutoFilter.Range.Copy Range("A1")
      wb.SaveAs ThisWorkbook.Path & "\" & ky
      wb.Close False
    Next
  End With
 
  Sheet1.ShowAllData
  Application.ScreenUpdating = True
End Sub

Thanks for this Dante.

It works, but not quite. My sheet contains the list of managers in column F, not A. Also, this code seems to lose source formatting when I run it?

 

[DanteAmor]

It works, but not quite. My sheet contains the list of managers in column F, not A. Also, this code seems to lose source formatting when I run it?

Try the following, I adjusted the separation for column F and this copying exactly the same as your code does.
Try again.

Sub SplitIntoBooks()
  Dim wb As Workbook, c As Range, ky As Variant
  Dim lr As Long, lc As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Sheet1.Range("A1").AutoFilter
  lr = Sheet1.Range("F" & Rows.Count).End(3).Row
  lc = Sheet1.Cells(1, Columns.Count).End(1).Column
  With CreateObject("scripting.dictionary")
    For Each c In Sheet1.Range("F2:F" & lr)
      .Item(c.Value) = Empty
    Next
    For Each ky In .Keys
      Sheet1.Range("A1", Sheet1.Cells(lr, lc)).AutoFilter 6, ky
      Set wb = Workbooks.Add(xlWBATWorksheet)
      Sheet1.AutoFilter.Range.Copy
      Range("A1").PasteSpecial xlPasteAll
      wb.SaveAs ThisWorkbook.Path & "\" & ky
      wb.Close False
    Next
  End With
  
  Sheet1.ShowAllData
  Application.ScreenUpdating = True
End Sub

 

[alansidman]

crossposted: Split sheet into separate workbooks using VBA on Excel 365 - OzGrid Free Excel/VBA Help Forum

Please read: Excelguru Help Site - A message to forum cross posters

 

[Fluff]

@jvdm
While we do allow Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules). This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.