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