Creating workbooks for a team of staff

OZSamwise

New Member
Joined
Sep 8, 2024
Messages
1
Office Version
  1. 365
Platform
  1. Windows
Hi All,

VBA rookie here, sorry in advance if my explanation is not clear.

I have a worksheet full of monthly efficiencies for our employees that is required to be separated either into individual workbooks or into a teams workbook (separate sheets with their names) along with their efficiencies. (would prefer the team workbook)
i.e team Leader 1 and then 11 employees, Team Leader 2 and 5 employees.

There are 4 teams each with a different amount of employees. I have a macro that separates each staff member into separate worksheets however have been scratching my brain how to convert this into a seperate team workbook as when the new book is created with the sheets it has been filtered alphabetically and throws out the teams.

Below is an example of the sheet I have and the macro I have been using (sourced this from google).

Any guidance is much appreciated

1725846073506.png



Sub SplitNames_newWB()

Const N As Integer = 2

Const sCol$ = "A"

Const srcName$ = "Sheet1"

Dim c As New Collection, cItem

Dim wb1 As Workbook, wb2 As Workbook

Dim ws As Worksheet, ws1 As Worksheet

Dim sPath As String, strDate As String

Dim r As Long, i As Long, j As Long

Dim cc As Variant

Set wb1 = ThisWorkbook

Set ws = wb1.Sheets(srcName)

sPath = ThisWorkbook.Path

Application.ScreenUpdating = False

ws.AutoFilterMode = False

r = ws.Cells(Rows.Count, 1).End(xlUp).Row

On Error Resume Next

For Each cItem In ws.Range(sCol & N + 1 & ":" & sCol & r)

c.Add cItem, cItem

Next

On Error GoTo 0

Set wb2 = Workbooks.Add(1)

For Each cc In c

ws.Range(ws.Cells(N, sCol), ws.Cells(r, sCol)).AutoFilter Field:=1, Criteria1:=cc

Set ws1 = wb2.Worksheets.Add(After:=wb2.Worksheets(wb2.Worksheets.Count))

ws1.Name = cc

ws.Rows("1:" & r).SpecialCells(xlCellTypeVisible).Copy

With ws1.Range("A1")

.PasteSpecial Paste:=xlPasteFormats

.PasteSpecial Paste:=xlPasteValues

End With

Application.CutCopyMode = False

ActiveSheet.UsedRange.EntireColumn.AutoFit

Next cc

ws.AutoFilterMode = False

Application.DisplayAlerts = False

wb2.Sheets(1).Delete

strDate = Format(Now, "yyyymmdd_hhmm")

wb2.SaveAs sPath & "\" & strDate & ".xlsx"

Application.DisplayAlerts = True

For i = 1 To wb2.Sheets.Count - 1

For j = i + 1 To wb2.Sheets.Count

If UCase(wb2.Sheets(j).Name) < UCase(wb2.Sheets(i).Name) Then

wb2.Sheets(j).Move before:=wb2.Sheets(i)

End If

Next j

Next i

wb2.Sheets(1).Select

wb2.Save

wb2.Close False

Application.ScreenUpdating = True

MsgBox "new wb" & vbCr & strDate & ".xlsx" & vbCr & "is ready in this wb path"

End Sub
 

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.
Hi All,

VBA rookie here, sorry in advance if my explanation is not clear.

I have a worksheet full of monthly efficiencies for our employees that is required to be separated either into individual workbooks or into a teams workbook (separate sheets with their names) along with their efficiencies. (would prefer the team workbook)
i.e team Leader 1 and then 11 employees, Team Leader 2 and 5 employees.

There are 4 teams each with a different amount of employees. I have a macro that separates each staff member into separate worksheets however have been scratching my brain how to convert this into a seperate team workbook as when the new book is created with the sheets it has been filtered alphabetically and throws out the teams.

Below is an example of the sheet I have and the macro I have been using (sourced this from google).

Any guidance is much appreciated

View attachment 116601


Sub SplitNames_newWB()

Const N As Integer = 2

Const sCol$ = "A"

Const srcName$ = "Sheet1"

Dim c As New Collection, cItem

Dim wb1 As Workbook, wb2 As Workbook

Dim ws As Worksheet, ws1 As Worksheet

Dim sPath As String, strDate As String

Dim r As Long, i As Long, j As Long

Dim cc As Variant

Set wb1 = ThisWorkbook

Set ws = wb1.Sheets(srcName)

sPath = ThisWorkbook.Path

Application.ScreenUpdating = False

ws.AutoFilterMode = False

r = ws.Cells(Rows.Count, 1).End(xlUp).Row

On Error Resume Next

For Each cItem In ws.Range(sCol & N + 1 & ":" & sCol & r)

c.Add cItem, cItem

Next

On Error GoTo 0

Set wb2 = Workbooks.Add(1)

For Each cc In c

ws.Range(ws.Cells(N, sCol), ws.Cells(r, sCol)).AutoFilter Field:=1, Criteria1:=cc

Set ws1 = wb2.Worksheets.Add(After:=wb2.Worksheets(wb2.Worksheets.Count))

ws1.Name = cc

ws.Rows("1:" & r).SpecialCells(xlCellTypeVisible).Copy

With ws1.Range("A1")

.PasteSpecial Paste:=xlPasteFormats

.PasteSpecial Paste:=xlPasteValues

End With

Application.CutCopyMode = False

ActiveSheet.UsedRange.EntireColumn.AutoFit

Next cc

ws.AutoFilterMode = False

Application.DisplayAlerts = False

wb2.Sheets(1).Delete

strDate = Format(Now, "yyyymmdd_hhmm")

wb2.SaveAs sPath & "\" & strDate & ".xlsx"

Application.DisplayAlerts = True

For i = 1 To wb2.Sheets.Count - 1

For j = i + 1 To wb2.Sheets.Count

If UCase(wb2.Sheets(j).Name) < UCase(wb2.Sheets(i).Name) Then

wb2.Sheets(j).Move before:=wb2.Sheets(i)

End If

Next j

Next i

wb2.Sheets(1).Select

wb2.Save

wb2.Close False

Application.ScreenUpdating = True

MsgBox "new wb" & vbCr & strDate & ".xlsx" & vbCr & "is ready in this wb path"

End Sub
How do you identify which team the members are in to accommodate changes to team structures? Maybe a new column one with the team number in.
What workbook and worksheet naming convention do you need?
Does the individual worksheet only contain one line of data?
You could have the same worksheet for the team and individual with the individual line highlighted.
 
Upvote 0

Forum statistics

Threads
1,224,595
Messages
6,179,798
Members
452,943
Latest member
Newbie4296

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