Generate new workbooks based on column value from multiple worksheets

[MrBeginner]

Hi,

I am a beginner in VBA. Basically I need a code that generates a new workbook for each specific column value in multiple sheets. The key in each sheet is the column Group.
In total there are 6 sheets in the original file with the following columns. Sheet General Data Location Project Project Manager Status Group Sheet Costs Location Group Project Costs
Sheet Costs Last month Location Group Project Costs last month
Sheet issues Location Project Project Manager Issues Group
Additionally there are two other sheets in the wb that need to be transferred as well but kept as they are. ("Overview" and "Summary"). Thank you.

 

[MrBeginner]

Sorry,
The columns are like this:

Sheet General Data
Location Project Project Manager Status Group
Sheet Costs
Location Group Project Costs
Sheet Costs Last month
Location Group Project Costs last month
Sheet issues
Location Project Project Manager Issues Group

 

[MrBeginner]

Could someone tell me the steps to do it simple?

 

[MrBeginner]

Here I have a draft, but it autofilters also the sheets "Summary" and "Overview". Therefore they are copied twice into the destination wb.


<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; white-space: inherit;">Dim ws As Worksheet, wb As Workbook, team
ForEach team In getTeams
Set wb = Workbooks.Add ' create a wb for each team with same # of sheets

DoUntil wb.Worksheets.Count >= ThisWorkbook.Worksheets.Count
wb.Worksheets.Add After:=wb.Sheets(wb.Sheets.Count)
Loop

ForEach ws In ThisWorkbook.Worksheets
If ws.Name <>"Overview"And ws.Name <>"Summary"Then
With ws.UsedRange
.AutoFilter 1, team ' filter to copy only the team's rows
.Copy wb.Sheets(ws.Index).Range("A1")
.AutoFilter
EndWith
EndIf
wb.Sheets(ws.Index).Name = ws.Name


Next

ThisWorkbook.Worksheets("Summary").Copy After:=wb.Sheets(wb.Sheets.Count)</code>ThisWorkbook.Worksheets("Overview").Copy After:=wb.Sheets(wb.Sheets.Count) wb.SaveAs "Project Budget Tracking " & team & ".xlsx"
<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; white-space: inherit;"> wb.Close False
Next

</code>Cleanup: Application.EnableEvents = True: Application.ScreenUpdating = True: Application.DisplayAlerts = True End Sub
Function getTeams() ' gets the unique team names using a dictionary Dim cel As Range, dict As Object Set dict = CreateObject("Scripting.Dictionary") With ThisWorkbook.Sheets("Sheet1") For Each cel In .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row) If Len(Trim(cel.Value2)) > 0 Then dict(cel.Value2) = 0 Next End With getTeams = dict.Keys End Function