VBA Code to split workbook into several smaller workbooks

[Wavid]

Hi There experts

Can someone please help me with a VBA code to split an Excel file with 1200 customers and save it in a specified location?

Earlier, I found two VBA codes that did the following
1. Split the Excel file into several tabs based on a prompted column input. The tabs had a unique name based on the column input
2. A second macro to split the worksheets into new workbooks and save them in a particular location

Any help will be appreciated.

 

[DanteAmor]

Hi and welcome to MrExcel

Adjust your data on these lines.
Set sh = Sheets("Sheet1") 'fit the name of your sheet with the codes.
wPath = ThisWorkbook.Path & "\" 'fit the folder, for example: "C:\files\"
col = "A" 'fit column with codes

I assume the headers are in row 1.


The following macro creates the files.
Do you also need to create the sheets?

Sub split_workbook()
  Dim sh As Worksheet, wb As Workbook, c As Range
  Dim ky As Variant, wPath As String, lr As Long, col As String
  
  Application.SheetsInNewWorkbook = 1
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh = Sheets("Sheet1")         'fit the name of your sheet with the codes.
  wPath = ThisWorkbook.Path & "\"   'fit the folder, for example: "C:\files\"
  col = "A"                         'fit column with codes
  
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  
  lr = sh.Range(col & Rows.Count).End(xlUp).Row
  
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range(col & "2:" & col & lr)
      .Item(c.Value) = Empty
    Next
    For Each ky In .Keys
      sh.Range("A1").AutoFilter 1, ky
      Set wb = Workbooks.Add
      sh.AutoFilter.Range.EntireRow.Copy Range("A1")
      wb.SaveAs wPath & ky
      wb.Close False
    Next
  End With
  sh.ShowAllData
End Sub

 

[Wavid]

Hi Dante
Thank you for welcoming me to this Forum and Thank you for being so helpful. I am very grateful to you for your time and assistance.
Is it possible to please help with creating the sheets.

 

[Wavid]

Hi and welcome to MrExcel

Adjust your data on these lines.
Set sh = Sheets("Sheet1") 'fit the name of your sheet with the codes.
wPath = ThisWorkbook.Path & "\" 'fit the folder, for example: "C:\files\"
col = "A" 'fit column with codes

I assume the headers are in row 1.


The following macro creates the files.
Do you also need to create the sheets?

Sub split_workbook()
  Dim sh As Worksheet, wb As Workbook, c As Range
  Dim ky As Variant, wPath As String, lr As Long, col As String
 
  Application.SheetsInNewWorkbook = 1
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Set sh = Sheets("Sheet1")         'fit the name of your sheet with the codes.
  wPath = ThisWorkbook.Path & "\"   'fit the folder, for example: "C:\files\"
  col = "A"                         'fit column with codes
 
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
 
  lr = sh.Range(col & Rows.Count).End(xlUp).Row
 
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range(col & "2:" & col & lr)
      .Item(c.Value) = Empty
    Next
    For Each ky In .Keys
      sh.Range("A1").AutoFilter 1, ky
      Set wb = Workbooks.Add
      sh.AutoFilter.Range.EntireRow.Copy Range("A1")
      wb.SaveAs wPath & ky
      wb.Close False
    Next
  End With
  sh.ShowAllData
End Sub

Hi Dante
Thank you for welcoming me to this Forum and Thank you for being so helpful. I am very grateful to you for your time and assistance.
Is it possible to please help with creating the sheets.

 

[Fuji]

Try

Sub test()
    Dim x, e
    Const myCol& = 1  '<--- filter column index
    Application.ScreenUpdating = False
    With Sheets("sheet1")   '<--- change sheet1 to actual data sheet name
        If .FilterMode Then .ShowAllData
        With .Range("a1", .Cells.SpecialCells(11))
            x = Application.Sort(Application.Unique(.Columns(myCol).Offset(1)))
            For Each e In x
                If e <> "" Then
                    If Not Evaluate("isref('" & e & "'!a1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = e
                    Sheets(CStr(e)).UsedRange.Clear
                    .AutoFilter myCol, e
                    .Copy Sheets(CStr(e)).[a1]
                    Sheets(CStr(e)).Copy
                    With ActiveWorkbook
                        .SaveAs ThisWorkbook.Path & "\" & e, 51
                        .Close
                    End With
                End If
            Next
        End With
    End With
    Application.ScreenUpdating = True
End Sub

 

[DanteAmor]

Is it possible to please help with creating the sheets.

I attach the macro with the changes to create the sheets and books.

Sub split_workbook()
  Dim sh As Worksheet, c As Range
  Dim ky As Variant, wPath As String, col As String
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set sh = Sheets("Sheet1")         'fit the name of your sheet with the codes.
  wPath = ThisWorkbook.Path & "\"   'fit the folder, for example: "C:\files\"
  col = "A"                         'fit column with codes
  
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range(col & "2:" & col & sh.Range(col & Rows.Count).End(xlUp).Row)
      .Item(c.Value) = Empty
    Next
    For Each ky In .Keys
      On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
      sh.Range("A1").AutoFilter 1, ky
      Sheets.Add(, Sheets(Sheets.Count)).Name = ky
      sh.AutoFilter.Range.EntireRow.Copy Range("A1")
      Sheets(ky).Copy
      ActiveWorkbook.SaveAs wPath & ky
      ActiveWorkbook.Close False
    Next
  End With
  sh.Select
  sh.ShowAllData
End Sub