VBA to separate specific Tabs into separate workbooks

[redneckopen]

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.

 

[igold]

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.

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

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.

 

[redneckopen]

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

 

[igold]

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...

 

[redneckopen]

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.

 

[igold]

Does this get you any closer to your requirements...

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

 

[redneckopen]

I am getting a runtime error;

Workbooks(wbName).Worksheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete

 

[igold]

That is a "clean-up" line. Comment it out and try...

 

[redneckopen]

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)

 

[igold]

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:

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.