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:
24250 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!
24260