VBA to separate specific Tabs into separate workbooks

redneckopen

Board Regular
Joined
Nov 2, 2004
Messages
224
How would I separate tabs into different workbook (no need to save at this point) by the first four characters of the Tab name using VBA?

example; Canada, Chile, Colombia, would be separated by cana, chil, colo. There is additional information on each tab but these would be leading.
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Does this do what you want. I am a little unclear of your requirements. Also I do not think you can name a workbook without saving it..

That said, the first code will cycle through all worksheets and break them out to separate workbooks. The second will let you hard code the sheet names that you want copied.

Code:
Sub names1()


    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim i As Long
    Dim ws As Worksheets
    For i = 1 To wb.Worksheets.Count  'All sheets in workbook
        Worksheets(i).Copy
        ActiveWorkbook.SaveAs Filename:=Left(Worksheets(1).Name, 4)
        wb.Activate
    Next
    
End Sub
or


Code:
Sub names2()


    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim wss
    Dim i As Long
    wss = Array("Canada", "Chile") 'Sheet names are hardcoded in
    For i = 0 To UBound(wss)
        Worksheets(wss(i)).Copy
        ActiveWorkbook.SaveAs Filename:=Left(Worksheets(1).Name, 4)
        wb.Activate
    Next
    
End Sub

I hope this helps.
 
Upvote 0
Maybe I wasn't clear enough. Let me try again.

I have multiple tabs that start with the same 4 characters with the following characters being different
example Baja2018BLUE1-literpot, Baja2018BlueRASP Roots, Baja2018STRAWRegular, Canada2018BLACKLongCane, Canada2018RASPLongCane etc.

I need to separate multiple tabs that begin with the same 4 characters in separate workbooks (by district)
workbook 1 = Baja2018BLUE1-literpot, Baja2018BlueRASP Roots, Baja2018STRAWRegular
workbook 2 = Canada2018BLACKLongCane, CANADA2018RASPLongCane
etc
etc
There are 40+ tabs to separate
 
Upvote 0
Do you have a list somewhere in the workbook of all the unique four character prefixes that you want the code to separate tabs by, or do you expect the code to look at every sheet name, extrapolate the first four characters of every tab, then create a unique list of those characters and move on from there...
 
Last edited:
Upvote 0
In cell C2 of each worksheet has the district which is represented as the first name in the tab. I am now having to copy each group of worksheet tabs by district into a new workbook and save it. I would like to automate that process if possible.
 
Upvote 0
Does this get you any closer to your requirements...

Code:
Sub names2()


    Dim NewName As String
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim Nwb As Workbook
    Dim wss As String, wbName As String
    Dim i As Long, x As Long, s As Long
    Dim sLines
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    For i = 1 To wb.Worksheets.Count
        wss = wss & "," & Worksheets(i).Range("C2")
    Next
    wss = Mid(wss, 2)
    sLines = Split(wss, ",")
    With CreateObject("Scripting.Dictionary")
        For x = LBound(sLines) To UBound(sLines)
            If Not IsMissing(sLines(x)) Then .Item(sLines(x)) = 1
        Next
        sLines = .Keys
    End With
    For s = 0 To UBound(sLines)
        Set Nwb = Workbooks.Add
        wbName = Application.Workbooks.Item(2).Name
        wb.Activate
        With wb
            For i = 1 To .Worksheets.Count
                If Worksheets(i).Range("C2") = sLines(s) Then
                    Worksheets(i).Copy Workbooks(wbName).Worksheets(3)
                    .Activate
                End If
            Next
        End With
        Workbooks(wbName).Activate
        Workbooks(wbName).Worksheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete
        NewName = InputBox("District " & sLines(s) & " Is Done." _
            & vbCrLf & "Please Enter the name for the new workbook", "New Workbook Name")
       With ActiveWorkbook
            .SaveAs (NewName & ".xlsx")
            .Close savechanges:=True
        End With
    Next
    MsgBox "Operation Complete"
    
End Sub
 
Upvote 0
I am getting a runtime error;

Workbooks(wbName).Worksheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete
 
Upvote 0
That is a "clean-up" line. Comment it out and try...
 
Upvote 0
That is a "clean-up" line. Comment it out and try...

I deleted the line (if that is what you meant by Comment it out)

Then I ran it and got an out of range error on
Worksheets(i).Copy Workbooks(wbName).Worksheets(3)
 
Upvote 0
To comment a line out, what you are doing is placing an apostrophe as the first character of the line. Excel will interpret that as a comment or remark and will not execute the line.

Change that to:

Code:
Worksheets(i).Copy Workbooks(wbName).Worksheets([COLOR=#ff0000]1[/COLOR])

When you open a new blank workbook, how many sheets does it have as default.
 
Upvote 0

Forum statistics

Threads
1,223,270
Messages
6,171,103
Members
452,379
Latest member
IainTru

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