Excel Macro/Code help: Creating sheet for each name in column of another sheet Solved/Closed

Question

Hello!
I am working on a project at my internship and ran into some issues finishing up some of the features I want to implement. The excel is a file to track training for a specific role at the company. The first sheet (pictured below) has a list of the employees and the courses as well as a record of the date of each employees' completion of the course. What I want to implement is something to create a specific sheet for each name in each column. The person's name should be the name of this new sheet and the sheet needs to follow a specific format (pictured below as well). As you can see, this new sheet pulls the original course list as well as that employee's completion record and then using formulas pulls any meaningful statistics from it. I am hoping there is some macro or code that can be made to execute this command and automatically update and create this sheet. If anyone could help me with creating this feature or if you know of a way to do it without macros/code, I would appreciate any help. (Note: due to the nature of my position I am unable to share the actual file but I have created an exact replica with replaced inputs (fake names, courses, dates, etc) to show how it would look like). Thank you in advance for any and all help!

Additional info: There are currently 22 courses in the sheet, with all sheets being built to automatically handle up to 55 courses. There are also currently 14 employees in the training program.






System Configuration: Windows / Chrome 91.0.4472.124

vcoolio · Answer

Hello ExcelNovice2019,

Based on the information that you have supplied, we have to assume that:-

- The only data that is transferred from your "Input" sheet to the individual Employee sheets would be the Course Name and the Employee completion record (which appears to be just dates).
- The remaining columns of data that you need in the individual Employee sheets are created by formulae that you already have ready to go.

If the assumptions are correct, then I would recommend having a "Template" sheet which is copied for each Employee. The template sheet would only require the course names listed in Column A with the remaining headings as per your second image.

A VBA sub-routine that could do this is as follows:-

Option Explicit
Sub Test()
        
        Dim wsI As Worksheet: Set wsI = Sheets("Input")
        Dim wsT As Worksheet: Set wsT = Sheets("Template")
        Dim ws As Worksheet
        Dim i As Long, lr As Long, Id As Object, key As Variant, lCol As Long
        
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

wsI.Range("D1:Q1").Copy
        wsI.[BA2].PasteSpecial xlValues, Transpose:=True
   
        Set Id = CreateObject("Scripting.Dictionary")
        lr = wsI.Range("A" & Rows.Count).End(xlUp).Row
        wsI.Range("D2:Q" & lr).Copy wsI.[BB2]
        
        For i = 2 To lr
              If Not Id.Exists(wsI.Range("BA" & i).Value) Then
              Id.Add wsI.Range("BA" & i).Value, 1
              End If
        Next i
        
        For Each key In Id.keys
              If Not Evaluate("ISREF('" & CStr(key) & "'!A1)") Then
              wsT.Copy After:=Sheets(Sheets.Count)
              ActiveSheet.Name = key
        End If
        
        Set ws = Sheets(CStr(key))
        ws.Range("B2", ws.Range("B" & ws.Rows.Count).End(xlUp)(2)).ClearContents
        lCol = wsI.Cells(2, Columns.Count).End(xlToLeft).Column
        
        With wsI.Range("BA1:BA" & lr)
              .AutoFilter 1, key
              .Offset(1, 1).Resize(, lCol).Copy
              ws.[B2].PasteSpecial xlValues, Transpose:=True
              .AutoFilter
        End With
              ws.Columns.AutoFit
        Next key
              wsI.Select
        
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

This sub will create a new worksheet for each employee based on a template sheet, name each sheet after each individual employee and then copy/paste the employee completion record with the formulae that you have implemented doing the rest.
All your formulae will need to be placed in the relative cells in the template sheet.

I've attached a mock-up workbook at the below link with the code implemented showing how this would work. Just click on the "TEST" button.

https://wetransfer.com/downloads/84f40d7044c84b88eb38fcaa2cea866620210715111702/73fb93

I hope that this helps.

Cheerio,
vcoolio.

excelnovice2019 · Answer

Hey vcoolio!
Thank you so much for your help! I implemented the code and am testing it and am encountering some issues. When I run the macro it gives me "Run time error '13': type mismatch". The line of code is "If Not Evaluate("ISREF('" & CStr(key) & "'!A1)") Then". The macro still runs somewhat successfully. It does create a sheet for each name and follows the template. However (and I think this is what the run time error is referring to) each template has incorrect dates. For example name 1 in column 1 would have dates going across row 1 (for course 1) when it needs to have the dates in column 1. The only other issue I see is when it copies the completion dates over and applies to the template, it erases the tentative completion date column, leaving it blank/devoid of the original formula.
One final question: would it be possible to have the copied over completion dates refer back to the original table it was copied from so that should any date be modified in the future each individual sheet will automaticaaly match? Thanks again!
Sincerely,
excelnovice

vcoolio · Answer

Hello ExcelNovice,

In the sample that I have supplied, I cannot replicate the error and the entire process works as it should. If you are receiving an error "Type MisMatch" then this would suggest that your actual workbook is not set out as per the information supplied.

 "For example name 1 in column 1 would have dates going across row 1 (for course 1) when it needs to have the dates in column 1."

Are you referring to the Template sheet? The dates in each template copy are placed in Column B(2 not 1), vertically not horizontally.

"One final question: would it be possible to have the copied over completion dates refer back to the original table it was copied from so that should any date be modified in the future each individual sheet will automaticaaly match? "

I'm assuming that your are referring to a 'refresh'. Once any data is changed in the 'Input' sheet, simply click on the button again to update the destination sheets.

I think that the best thing for you to do next is to upload a sample of your workbook to a free file sharing site such as WeTransfer or Drop Box and then post the link to your file back here. Ensure that the sample is an exact replica of your actual workbook. Please use dummy data.

Cheerio,
vcoolio.

vcoolio · Answer

Hello ExcelNovice,

An adjustment to the transpose function should sort it out for you. Here's the amended code:-

Option Explicit
Sub Test()
        
        Dim wsI As Worksheet: Set wsI = Sheets("Full Table")
        Dim wsT As Worksheet: Set wsT = Sheets("Template")
        Dim ws As Worksheet
        Dim i As Long, lr As Long, Id As Object, key As Variant, lCol As Long
        
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

wsI.Range("D1:Q1").Copy
        wsI.[BA2].PasteSpecial xlValues, Transpose:=True
   
        Set Id = CreateObject("Scripting.Dictionary")
        lr = wsI.Range("A" & Rows.Count).End(xlUp).Row
        wsI.Range("D2:Q" & lr).Copy
        wsI.[BB2].PasteSpecial , Transpose:=True
        
        For i = 2 To lr
              If Not Id.Exists(wsI.Range("BA" & i).Value) Then
              Id.Add wsI.Range("BA" & i).Value, 1
              End If
        Next i
        On Error Resume Next
        For Each key In Id.keys
              If Not Evaluate("ISREF('" & CStr(key) & "'!A1)") Then
              wsT.Copy After:=Sheets(Sheets.Count)
              ActiveSheet.Name = key
              End If
              
              Set ws = Sheets(CStr(key))
              ws.Range("B2", ws.Range("B" & ws.Rows.Count).End(xlUp)(2)).ClearContents
              lCol = wsI.Cells(2, Columns.Count).End(xlToLeft).Column
            
              With wsI.Range("BA1:BA" & lr)
                      .AutoFilter 1, key
                      .Offset(1, 1).Resize(, lCol).Copy
                      ws.[GA2].PasteSpecial , Transpose:=True
                      ws.Range("GA2", ws.Range("GA" & ws.Rows.Count).End(xlUp)).Copy ws.[B2]
                      .AutoFilter
              End With
              ws.Columns.AutoFit
        Next key
              wsI.Select
        For Each ws In Worksheets
        If Right(ws.Name, 3) Like "(#)" Then ws.Delete
        Next ws

Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Also, in the Template sheet, clear the contents of Column B and save the workbook as such. You don't need formulae in this column. These formulae are extracting data from the "Full Table" sheet which is what the code is supposed to do.

I hope that this helps.

Cheerio,
vcoolio.

vcoolio · Answer

Hello ExcelNovice,

I've made a few changes to the code to tidy it up a little further for you. It is now dynamic (not hard coded) for the columns to allow for any future column additions which means you won't have to alter the code to allow for additional columns.
I've also added a helper worksheet to do some of the nitty gritty stuff. I was previously using the nether regions of the main sheet to do this but it created too much clutter for my liking. In the code, you'll see it as the variable wsH. Just to be original, I've named it "Helper".
Hence, in your actual workbook, open a new sheet, name it "Helper", add a few headings in row1 (anything will do!) for a few columns starting with Column A then save the changes to the workbook.

Here's the updated code:-

Option Explicit
Sub Test()
        
        Dim wsI As Worksheet: Set wsI = Sheets("Full Table")
        Dim wsT As Worksheet: Set wsT = Sheets("Template")
        Dim wsH As Worksheet: Set wsH = Sheets("Helper")
        Dim ws As Worksheet, Id As Object, key As Variant
        Dim i As Long, lr As Long, lrH As Long, lCol As Long
        
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
        
        wsH.UsedRange.Offset(1).Clear
        lCol = wsI.Cells(1, Columns.Count).End(xlToLeft).Column
        wsI.Range("D1").Resize(, lCol).Copy '----> Dynamic for columns, not hard coded.
        wsH.[A2].PasteSpecial xlValues, Transpose:=True
   
        Set Id = CreateObject("Scripting.Dictionary")
        lr = wsI.Range("A" & Rows.Count).End(xlUp).Row
        wsI.Range("D2:D" & lr).Resize(, lCol).Copy '----> Dynamic for columns, not hard coded.
        wsH.[B2].PasteSpecial , Transpose:=True
        
        lrH = wsH.Range("A" & Rows.Count).End(xlUp).Row
        
        For i = 2 To lrH
              If Not Id.Exists(wsH.Range("A" & i).Value) Then
                    Id.Add wsH.Range("A" & i).Value, 1
              End If
        Next i
    
        For Each key In Id.keys
              If Not Evaluate("ISREF('" & CStr(key) & "'!A1)") Then
                    wsT.Copy After:=Sheets(Sheets.Count)
                    ActiveSheet.Name = key
              End If
              
              Set ws = Sheets(CStr(key))
              ws.Range("B2", ws.Range("B" & ws.Rows.Count).End(xlUp)(2)).ClearContents
            
              With wsH.Range("A1", wsH.Range("A" & wsH.Rows.Count).End(xlUp))
                      .AutoFilter 1, key
                      .CurrentRegion.Offset(1, 1).Copy
                      ws.[GA2].PasteSpecial , Transpose:=True
                      ws.Range("GA2", ws.Range("GA" & ws.Rows.Count).End(xlUp)).Copy ws.[B2]
                      .AutoFilter
              End With
              ws.Columns.AutoFit
        Next key
              wsI.Select

Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Following is the link to your sample workbook with the changes implemented. The code is assigned to the button.

https://we.tl/t-FsaMheK0Dq

Add some more columns with test names and data then run the code to see if it's how you were hoping it would work.

I'll have a look at your other query over the next day or so. BTW, how do you envisage the set out of the "Archive" sheet?

I hope that this helps.

Cheerio,
vcoolio.

P.S. Remember to clear out Column B from row 2 in the Template sheet. The formulae in this column are not needed.

vcoolio · Answer

Hello ExcelNovice,

"As for the archive, I mostly envision it as just a sheet with the employee name and the date they completed all the training."

I'd assume then that the "Archive" sheet would have just two columns: Employee name (Column A) and completion date (Column B).

I was thinking that perhaps you could use the Individual Report sheet for this purpose. This sheet is obviously for employee assessment so it could be the best place to determine who to archive from. If so, I'd suggest that you use cell B2, in which you place employee names anyway, and cell C2 with the criteria "Course Completed". The names could be placed in a drop down data validation list in B2 and the criteria "Course Completed" could simply be typed in once the training assessor (I assume this would be you) considers that an employee has attained an acceptable percentage of training. I've noticed that once an employee name is placed in B2, their statistics populate due to the formulae that you have in place. Hence my reasoning for operating from this sheet.
I could quite easily create a sub-routine based on this to archive an employee and delete their respective column from the Full Table sheet. An event code could be used so no button would be required. The event would be triggered by typing the criteria "Course Completed" in C2.

Just some thoughts on what could be done for your final piece of the puzzle.

Cheerio,
vcoolio.

vcoolio · Answer

Hello EN,

Well, we could try this:

Firstly, create a copy of your actual workbook and name it something else (perhaps "My Scrap Heap"?!?).
Next, open a new worksheet and name it "Archive".
In row1 starting at Column A, place the following three headings:-
Employee, Date Courses Completed, No. of Courses Completed
(or name them whatever suits you).
In the Full Table sheet, in cell D25, place this formula:

=COUNTA(A2:A70)
(I'm assuming that you won't have any more than 70 courses).
This will give you a count of all courses. I've selected D25 randomly so if this whole exercise works for you, you can find a more suitable place for it and amend the code below (Private Sub Workbook_Open()) to suit.

Next, in the "Individual Report" sheet, place the same formula in cell C1 but amend it to A5:A70. 
In cell B1 of the same sheet, place the heading "Completed Courses:"
Still use B2 to place the employee name into and C2 to type the criteria "Courses completed".

In the same Module as the code that creates the new worksheets, paste this code just below it:-

Sub Test2()
        Dim c As Range, FindName As String, lr As Long, lcol As Long, wsI As Worksheet
        Set wsI = Sheets("Full Table")
        FindName = Sheet6.[B2].Value
        lcol = wsI.Cells(1, Columns.Count).End(xlToLeft).Column
        lr = wsI.Range("A" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

For Each c In wsI.Range("D1").Resize(, lcol)
                If c.Value = FindName Then
                c.EntireColumn.Delete
                End If
        Next c

Application.ScreenUpdating = True

End Sub

Now, in the 'ThisWorbook" module, place this code:-

Private Sub Workbook_Open()

Application.DisplayAlerts = False

Dim c As Range, wsI As Worksheet, wsAr As Worksheet, EmpName As String
        Set wsI = Sheets("Full Table")
        Set wsAr = Sheets("Archive")
        
Application.ScreenUpdating = False

For Each c In wsAr.Range("C2", wsAr.Range("C" & wsAr.Rows.Count).End(xlUp))
                If c.Value < wsI.[D25].Value Then
                EmpName = c.Offset(, -2).Value
                MsgBox "Employee " & EmpName & " " & "is required to complete additional courses." & vbNewLine & _
                "Please refer to the Full Table sheet for details.", vbExclamation, "COURSE UPDATE REQUIRED"
                Else: Exit Sub
                End If
        Next c

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

In the "Individual Report" sheet module, paste this code:-

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False

If Intersect(Target, Range("C2")) Is Nothing Then Exit Sub
        If Target.Value = vbNullString Then Exit Sub
        If Target.Count > 1 Then Exit Sub
        
        If Target.Value = "Courses completed" Then
                Target.Offset(, -1).Copy Sheets("Archive").Range("A" & Rows.Count).End(3)(2)
                Sheets("Archive").Range("B" & Rows.Count).End(3)(2) = Format(Date, "dd/mm/yyyy")
                Sheets("Archive").Range("C" & Rows.Count).End(3)(2) = Range("C1").Value
                Target.ClearContents
        End If

Sheets("Archive").Columns.WrapText = False
        Sheets("Archive").Columns.AutoFit
        Test2
        Range("B2").ClearContents
        
Application.ScreenUpdating = True

End Sub

In the "Individual Report" sheet, in cell B2, I'd recommend that you place a data validation drop down list of all employees. I've noticed discrepancies between the employee names in the "Full Table " sheet and those that you type into cell B2. These discrepancies are basically the inadvertent addition of 'ghost' characters, in this case additional leading/trailing spaces, additional spaces between names. These characters are mostly accidentally added but they will cause the code Test2 to fail as Excel always requires exact matches for this type of search code (any code actually). So please always ensure proper spelling and punctuation when cross-referencing. This is where a validation list will help you (and any other user) immensely. The name headings in the "Full Table" list HAVE to be exact matches.

The WorkBook_Open code will produce a message box each time the workbook is opened warning you that Employee such and such will need to complete further courses. The message box will appear for every employee who needs to complete more courses. If there is only one employee who has to, one message box will appear. If there are five employees who have to, five message boxes will appear one after the other giving you the name of each employee who is required to do further courses.

Hence, what to do next:-
- Save the copy workbook as an .xlsm file once you have added all the above codes, sheets, amendments etc..
- Open the copy workbook and run the code that creates the individual worksheets. Save this again.
- In the "Individual Report" sheet, select say Hannah Rizzo in B2. Cell C1 should be showing the total count of courses completed (assume all 22 are done and dusted).
- Type "Courses completed" in C2 then click away from the cell (or press Enter or down arrow). The employee name, date of completion, and course count will be added to the "Archive" sheet and the employee column will be deleted from the "Full Table" list. The course count in the "Archive" sheet is the key to warning you that and employee may need to do more courses.
- In the "Full Table" sheet, make a couple of dummy entries at the bottom of the current course list in Column A.
- Save and close the workbook. When you next open it, you'll see a message box appear with the warning as the course count (D25) is now greater than the count of Hannah's completed courses.

If you're not sure how to add an event code to a worksheet module, then here's how to implement them:-

With the Private Sub Worksheet_Change(ByVal Target As Range):-
- Right click on the "Individual Report" sheet tab.
- Select "View Code" from the menu that appears.
- In the big white code field that then appears, paste the code.

With the Private Sub Workbook_Open():-
-Open the VB Editor and over to the left in the Project Explorer, double click on 'ThisWorkbook'.
- In the big white code field, paste the code.

I hope that this helps.

Cheerio,
vcoolio.

vcoolio · Answer

.....................here's a link to a sample file:-

https://wetransfer.com/downloads/0cab9ac17e26d072230912d2c90f660320210719114321/5d0008

In this sample, one employee column has been deleted (22 courses completed) and I've saved the workbook with two additional courses added to the bottom of the course list in Column A.
The employee details should be in the Archive sheet.
When you open the file, the message box should appear.

Cheerio,
vcoolio.

P.S. In the Full Table sheet, I've actually placed the formula in C25.

vcoolio · Answer

Hello EN,

A) With creating a data validation drop down list, I think a good place to have it would be in the "Info Sheet".
Hence:-
- In your "Info Sheet", select a column two or three columns away from your other info and name it Employee List. Enter the names of all employees below the heading. Select the entire list including the heading.
- Go to the Formulas tab in the ribbon and in the Defined Names group, select Define Name. The 'New Name' dialogue box will appear with the column heading in the name box. In the 'Refers To' box, the cell references should be now showing. Click OK.
- With the list still high-lighted, go to the Insert tab in the ribbon and select 'Table'. The 'Create Table" dialogue box should appear. The 'Where is the data for your table?' box should now show the cell references. Tick the 'My table has headers' box. Click OK.
You now have a named range of employee names in table format.

Next:-
- Go to the Individual Report sheet, select cell B2. Go to the Data tab in the ribbon and in the Data Tools group, select Data Validation by clicking on the little drop down arrow. From the list that appears, select 'Data Validation'. The Data Validation dialogue box will appear.
- In this dialogue box, select List from the drop down in the Allow box.
- Click in the Source box then go to the newly created table an select the whole table. Once you have done this, the named range will appear in the Source box. Click OK.
You now have a data validation list in B2 of the Individual Report sheet. You can add or remove names as required in the list in the "Info Sheet". It's a good idea to sort the list when names are removed because, should you remove a name from the middle of the list, you'll end up with a blank cell within the drop down list. Click on the drop down icon beside the list name to do this. Blank cells will be moved to the bottom of the list.

Just to re-iterate from my previous post, ensure all names are spelled/punctuated exactly the same so that the headings and the drop down list match exactly.

B) As for  your query about reversing the archive process, the simplest method of salvaging the data would be to NOT save any changes. However, I have found that the best method of dealing with the wrong data being deleted is to prevent it from happening in the first place.

To do this, update the Private Sub Worksheet_Change(ByVal Target As Range) within the Individual Report sheet to this:-

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
        
        Dim Check As String, EmpName As String
        EmpName = Range("B2").Value
        
Application.ScreenUpdating = False

If Intersect(Target, Range("C2")) Is Nothing Then Exit Sub
        If Target.Value = vbNullString Then Exit Sub
        If Target.Count > 1 Then Exit Sub
        
        If Target.Value = "Courses completed" Then
        Check = MsgBox("With Employee: " & EmpName & vbNewLine & _
        "Are you sure that you have selected the correct details to archive and delete?", vbYesNo + vbCritical, "WARNING")
        If Check = vbNo Then Exit Sub
                Target.Offset(, -1).Copy Sheets("Archive").Range("A" & Rows.Count).End(3)(2)
                Sheets("Archive").Range("B" & Rows.Count).End(3)(2) = Format(Date, "dd/mm/yyyy")
                Sheets("Archive").Range("C" & Rows.Count).End(3)(2) = Range("C1").Value
                Target.ClearContents
        End If

Sheets("Archive").Columns.WrapText = False
        Sheets("Archive").Columns.AutoFit
        Test2
        Range("B2").ClearContents
        
Application.ScreenUpdating = True

End Sub


Before the code completely executes, a message box will appear basically asking the User to ensure that the correct details are to be archived and deleted. If the User realises an error and selects the "No" option, nothing will happen. If the User has checked and ensured that all is well and selects the "Yes" option, the code will fully execute.
My wife works at a law firm and I've programmed this method into a couple of her workbooks as she became totally frustrated with "clever" Users making the very same mistake that you mention (always in a rush!). She has quite a few "clever" people working around her! The success rate with this method at her workplace is so far 100%. I suppose that there's a psychological aspect to this: having a warning message continually slapped in your face each time you click a button asking you to check something is correct before doing something else. It makes a User mad enough to actually be aware that something may not be correct.

Furthermore, one more thing I would like your help to solve. If you look at the overall stat sheet, you will see I refer to the full table to pull the names into this sheet. This presents a problem as if a user is archived they are removed from the full table. However, I still want to use their training statistics. I just need a way to have the name populate in this table for my lookup formulas to work. 

As each individual's worksheet still remains after having their column deleted from the Full Table sheet, could you not extract the data from there?

Cheerio,
vcoolio.

vcoolio · Answer

Hello EN,

A good method that will do the same task for you and ignore blanks is to use the AGGREGATE function:-

E.G.:
=AGGREGATE(4,6,C1:O1)

- The number 4 specifies MAX.
- The number 6 is the option to ignore errors. This includes blanks.
- I've randomly made up the range(C1:O1) so test it on your actual range.

To obtain an understanding of how this very powerful function works, test it by selecting any blank cell then type in 
=AGGREGATE(  
When you've typed in the first "(" a list of function options will appear and you'll see that MAX is number 4. Next, after you've typed in a comma after the 4, another list of options will appear and you'll see that the number 6 (ignore error values) is, in this case, your required option. After you've typed in the next comma, add the required range and close the formula off with the final parentheses.

Cheerio,
vcoolio.

vcoolio · Answer

Hello EN,

You may be better off using the COUNTIF function but without seeing how you've implemented your formula I'd just be guessing.
Upload another sample showing the formula implemented and how you're using it with the expected result.

Cheerio,
vcoolio.

vcoolio · Answer

Good day EN,

Excellent! Good to know that you've sorted it out and you're welcome. I'm glad to have been able to assist.
Good luck with your internship.

Cheerio,
vcoolio.

Excel Macro/Code help: Creating sheet for each name in column of another sheet

12 responses

Similar discussions

Subscribe To Our Newsletter!