VBA Copy Sheets to New Workbook

[MikoSDS]

Hello Everyone,

I am struggling with some problem... So I would like to have a macro which is copying sheets in specific area and create new workbook with those sheets, for example:
excel.jpg in first step the macro should copy all sheets from range 1-2 (the red sheets) and the new workbook should be named like the first sheet (General) and the next step is doing the same, but new workbook will be with name "General 2" and the sheets in this workbook are between 4 and 5. Below is my code. Thank you all for help!

Sub Report()
Dim Wb As Workbook
Dim dateStr As String
Dim NewWorkBookName As String
Dim myDate As Date
Dim Links As Variant
Dim i As Integer
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Set Wb = ActiveWorkbook
myDate = Date
dateStr = Format(myDate, "MM-DD-YYYY")
NewWorkBookName = "General"
Wb.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Copy
With ActiveWorkbook
Links = .LinkSources(xlExcelLinks)
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
.BreakLink Links(i), xlLinkTypeExcelLinks
Next i
End If
End With
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & NewWorkBookName & " " & dateStr
ActiveWorkbook.Close
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub

[大灰狼1976]

Hi MikoSDS!
Welcome to vbax forum.
Is the red worksheet(1,2,3,4,5) actually there or did you add it for illustration?
Can you upload a real attachment to illustrate it?

[MikoSDS]

Yeah, sure. The excel file is in attached

[georgiboy]

I was looking at this just now. May not be the best solution but thought i would share it anyway:

Sub Report()    
    Dim Wb As Workbook
    Dim dateStr As String
    Dim NewWorkBookName As String
    Dim Links As Variant
    Dim i As Integer
    Dim v As Variant, ws As Worksheet
    Dim tmpV As Variant
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
    
    ReDim v(1 To Sheets.Count)
    For Each ws In ThisWorkbook.Worksheets
        If LCase(Left(ws.Name, 7)) = "general" Then
            x = x + 1
            v(x) = ws.Name
        Else
            v(x) = v(x) & "," & ws.Name
        End If
    Next ws
    
    Set Wb = ActiveWorkbook
    dateStr = Format(Date, "MM-DD-YYYY")
    
    For a = 1 To x
        tmpV = Split(v(a), ",")
        NewWorkBookName = tmpV(0)
        
        For t = 1 To UBound(tmpV)
            tmpV(t - 1) = tmpV(t)
        Next t
        ReDim Preserve tmpV(UBound(tmpV) - 1)


        Wb.Sheets(tmpV).Copy
        
        With ActiveWorkbook
            Links = .LinkSources(xlExcelLinks)
            If Not IsEmpty(Links) Then
                For i = 1 To UBound(Links)
                    .BreakLink Links(i), xlLinkTypeExcelLinks
                Next i
            End If
        End With
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & NewWorkBookName & " " & dateStr
        ActiveWorkbook.Close
    Next a
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
    
End Sub

Hope this helps

[MikoSDS]

Works perfectly! But I have a few question, so I would like to copy the "general" sheets too to the new workbooks. Also, if I would like to have another names instead of "general", but for example "reporting cluster" and then "consulting cluster" & "general cluster" & "integrated" what I have to do? Or maybe it will be simpler to have worksheets names in cells and macro will read the cells names, search the specific worksheets and then copy like now. Thank you!

[georgiboy]

Cool,

Personally i would use some kind of identifier for these tabs, it could be as simple as a "-" symbol at the start of the sheet name to tell the code that this is to be the name of the created spreadsheet.
You could also go down the route of listing the sheets if you like.

As for the extra sheet: there was some code that removed the first sheet as i thought you did not want it, i have now removed this piece so it should keep the main sheet now.

Untested:

Sub Report()    
    Dim Wb As Workbook
    Dim dateStr As String
    Dim NewWorkBookName As String
    Dim Links As Variant
    Dim i As Integer
    Dim v As Variant, ws As Worksheet
    Dim tmpV As Variant
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
    
    ReDim v(1 To Sheets.Count)
    For Each ws In ThisWorkbook.Worksheets
        If LCase(Left(ws.Name, 1)) = "-" Then
            x = x + 1
            v(x) = ws.Name
        Else
            v(x) = v(x) & "," & ws.Name
        End If
    Next ws
    
    Set Wb = ActiveWorkbook
    dateStr = Format(Date, "MM-DD-YYYY")
    
    For a = 1 To x
        tmpV = Split(v(a), ",")
        NewWorkBookName = tmpV(0)
        
        Wb.Sheets(tmpV).Copy
        
        With ActiveWorkbook
            Links = .LinkSources(xlExcelLinks)
            If Not IsEmpty(Links) Then
                For i = 1 To UBound(Links)
                    .BreakLink Links(i), xlLinkTypeExcelLinks
                Next i
            End If
        End With
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & NewWorkBookName & " " & dateStr
        ActiveWorkbook.Close
    Next a
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
    
End Sub

Hope this helps

[MikoSDS]

Wonderful! It's working, but as I have tested this code doesn't ignore hidden sheets, is there any way to do something like If Worksheets.Visible = True Then do the code. Or to do the list like I said before, example: "Reporting Cluster" is the main sheet and sheets belongs to this are: "a" "b" "c" ? Thank you once again!

Something like below: Macro will copy only sheets which are in the A1:A4 range, so the hidden sheets will be skipped too! Thanks!
list.jpg