Splitting Excel sheets by name into separate files with multiple sheets per file

[Alex240]

Hi,

I'm trying to find a quicker way to do a work task but as my VBA skills are rudimentary I don't know if it is possible to do or not.

Essentially I have a file with multiple tabs (example names 'KB123 X, KB123 Y, KB123 Z, KB456 Y, KB456 Z etc) and what I need to end up with are separate files, one of which has all the KB123 sheets, another with all the KB456 sheets etc, named in a specific way (e.g. combined KB123 Month). There are probably in the realm of 100 sheets, needing to be split into about 20 files but there are different numbers of sheets for each ID code. Some of the sheets I don't actually need at all but as those have a different ID codes to the ones I do need I figure I can just delete the files for those afterwards.

I have found a macro to separate the sheets into individual files, but as I still would then have to merge them manually that doesn't save me any time on top of the current 'ctrl click on all KB123 tabs, copy into new workbook, save, repeat' that I am already doing.

Any help would be very welcome but please express it in a 'for dummies' way as I am still learning.

Thanks.

 

[DanteAmor]

Hi @Alex240. Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.

Check the following points:

1. According to your examples, the macro will only consider the sheets whose name has a space:

2. The name of the new file will have the code and the abbreviation of the current month, for example "KB123 apr.xlsx"

named in a specific way (e.g. combined KB123 Month)

3. The files will be saved in the folder where you have the file with the macro.


Try the following macro:

Sub Splitting_Excel_Sheets()
  Dim dic As Object
  Dim sh As Worksheet
  Dim prefix As String
  Dim ws() As Variant, ky As Variant, shname As Variant
  Dim n As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set dic = CreateObject("Scripting.Dictionary")
  
  For Each sh In Sheets
    If InStr(1, sh.Name, " ") > 0 Then
      prefix = Split(sh.Name, " ")(0)
      If Not dic.exists(prefix) Then
        dic(prefix) = sh.Name
      Else
        dic(prefix) = dic(prefix) & "|" & sh.Name
      End If
    End If
  Next

  For Each ky In dic.keys
    n = 0
    For Each shname In Split(dic(ky), "|")
      ReDim Preserve ws(n)
      ws(n) = shname
      n = n + 1
    Next
    Sheets(ws).Copy
    ActiveWorkbook.SaveAs _
      Filename:=ThisWorkbook.Path & "\" & ky & " " & Format(Date, "mmm") & ".xlsx", _
      FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close False
  Next
  
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
--------------

 

[Alex240]

Hi @Alex240. Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.

Check the following points:

1. According to your examples, the macro will only consider the sheets whose name has a space:
View attachment 89111

2. The name of the new file will have the code and the abbreviation of the current month, for example "KB123 apr.xlsx"


3. The files will be saved in the folder where you have the file with the macro.


Try the following macro:

Sub Splitting_Excel_Sheets()
  Dim dic As Object
  Dim sh As Worksheet
  Dim prefix As String
  Dim ws() As Variant, ky As Variant, shname As Variant
  Dim n As Long
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set dic = CreateObject("Scripting.Dictionary")
 
  For Each sh In Sheets
    If InStr(1, sh.Name, " ") > 0 Then
      prefix = Split(sh.Name, " ")(0)
      If Not dic.exists(prefix) Then
        dic(prefix) = sh.Name
      Else
        dic(prefix) = dic(prefix) & "|" & sh.Name
      End If
    End If
  Next

  For Each ky In dic.keys
    n = 0
    For Each shname In Split(dic(ky), "|")
      ReDim Preserve ws(n)
      ws(n) = shname
      n = n + 1
    Next
    Sheets(ws).Copy
    ActiveWorkbook.SaveAs _
      Filename:=ThisWorkbook.Path & "\" & ky & " " & Format(Date, "mmm") & ".xlsx", _
      FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close False
  Next
 
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
--------------

Hi Dante,

This does exactly what I needed it to, all I've had to do is tweak the naming to exactly what I need. That is absolutely fantastic and will save me hours every month of tedious copy paste rename activity.

Thank you very much!!

Alex