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

Alex240

New Member
Joined
Apr 5, 2023
Messages
2
Office Version
  1. 365
Platform
  1. Windows
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.
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
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:
1680708708097.png


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:
VBA Code:
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
--------------
 
Upvote 1
Solution
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:
VBA Code:
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
 
Upvote 1

Forum statistics

Threads
1,223,888
Messages
6,175,212
Members
452,618
Latest member
Tam84

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top