Copy worksheet based on the number of names in the summary and name the sheets

[Mohammed Abu Hawash]

Good Day All

I have a summary worksheet which contains names of the worker in column A, the count of names is not constant, and I have another sheet for appraisal. I need a VBA code to copy the appraisal sheet for each of the workers in the summary and name the sheet with the worker's name.
After creating the sheets for each of the workers, I need the below data to be copied from the summary sheet to each of the sheets according to the worker's name owning the appraisal sheet:

Worker Name from Column A to appraisal sheet Cell D20
Worker Position from Column B to appraisal sheet Cell D21
Worker Department from Column C to appraisal sheet Cell D22
Worker Appointment from Column D to appraisal sheet Cell D23

Then to create link of the Total Points located on Cell K39 in each of the appraisal sheets to the summary sheet Column E. And to also create link of the Grade located on Cell K40 in each of the appraisal sheets to the summary sheet Column F.

I would appreciate any help on this thread

I'm using Michrosoft Excel 2007 on Windows 7

Thank you all for the anticipated help
Moh'd

 

[al_b_cnu]

Hi,

This macro assumes your summary sheet is named 'Summary'(amend the constant at the top of the code if different)

Option Explicit
Const msSummarySheetName As String = "Summary"
Sub CreateNameSheets()
Dim iSheetCount As Integer, iPtr As Integer
Dim lRow As Long
Dim sCurName As String
Dim vaInput As Variant, vaOutput As Variant
Dim wsInput As Worksheet, wsOutput As Worksheet

Set wsInput = Sheets(msSummarySheetName)
vaInput = Intersect(wsInput.Columns("A:D"), wsInput.UsedRange).Value

ReDim vaOutput(1 To 4, 1 To 1)
For lRow = 2 To UBound(vaInput, 1)
    sCurName = Trim$(vaInput(lRow, 1))
    If sCurName <> "" Then
        On Error Resume Next
        Set wsOutput = Nothing
        Set wsOutput = Sheets(sCurName)
        On Error GoTo 0
        If wsOutput Is Nothing Then
            iSheetCount = ThisWorkbook.Sheets.Count
            Set wsOutput = ThisWorkbook.Sheets.Add(after:=Sheets(iSheetCount))
            wsOutput.Name = sCurName
            On Error Resume Next
        End If
        
        For iPtr = 1 To 4
            vaOutput(iPtr, 1) = vaInput(lRow, iPtr)
        Next iPtr
        wsOutput.Range("D20:D23").Value = vaOutput
        
        
        wsInput.Hyperlinks.Add Anchor:=wsInput.Range("E" & lRow), _
                               Address:="", _
                               SubAddress:="'" & wsOutput.Name & "'!K39", _
                               TextToDisplay:="Total Points"
        wsInput.Hyperlinks.Add Anchor:=wsInput.Range("F" & lRow), _
                               Address:="", _
                               SubAddress:="'" & wsOutput.Name & "'!K40", _
                               TextToDisplay:="Grade"
    End If
Next lRow
End Sub

 

[Mohammed Abu Hawash]

Thank you Alan for your help, but I actually meant to copy the appraisal sheet, which already exists as an appraisal form, and I don't need to create a new sheet. Also what I meant by links, is for the values of cells K39 & K40 to appear in the positions of the Hyperlinks.

I still appreciate the code of the Hyperlinks as it has brought a new idea to apply on the pages.

Thank you again

 

[al_b_cnu]

Hi,

Try this macro, which assumes the name of the Appraisal sheet is 'appraisal":

Option Explicit
Const msSummarySheetName As String = "Summary"
Const msTemplateSheet As String = "Appraisal"

Sub CreateNameSheets()
Dim iSheetCount As Integer, iPtr As Integer
Dim lRow As Long
Dim sCurName As String
Dim vaInput As Variant, vaOutput As Variant
Dim wsInput As Worksheet, wsOutput As Worksheet, wsTemplate As Worksheet

Set wsInput = Sheets(msSummarySheetName)
Set wsTemplate = Sheets(msTemplateSheet)

vaInput = Intersect(wsInput.Columns("A:D"), wsInput.UsedRange).Value

ReDim vaOutput(1 To 4, 1 To 1)
For lRow = 2 To UBound(vaInput, 1)
    sCurName = Trim$(vaInput(lRow, 1))
    If sCurName <> "" Then
        On Error Resume Next
        Set wsOutput = Nothing
        Set wsOutput = Sheets(sCurName)
        On Error GoTo 0
        If wsOutput Is Nothing Then
            iSheetCount = ThisWorkbook.Sheets.Count
            Set wsOutput = ThisWorkbook.Sheets.Add(after:=Sheets(iSheetCount))
            wsOutput.Name = sCurName
            On Error Resume Next
        End If
        wsTemplate.Cells.Copy Destination:=wsOutput.Range("A1")
        
        For iPtr = 1 To 4
            vaOutput(iPtr, 1) = vaInput(lRow, iPtr)
        Next iPtr
        wsOutput.Range("D20:D23").Value = vaOutput
        wsInput.Range("E" & lRow).Formula = "='" & wsOutput.Name & "'!K39"
        wsInput.Range("F" & lRow).Formula = "='" & wsOutput.Name & "'!K40"
        
'        wsInput.Hyperlinks.Add Anchor:=wsInput.Range("E" & lRow), _
'                               Address:="", _
'                               SubAddress:="'" & wsOutput.Name & "'!K39", _
'                               TextToDisplay:="Total Points"
'        wsInput.Hyperlinks.Add Anchor:=wsInput.Range("F" & lRow), _
'                               Address:="", _
'                               SubAddress:="'" & wsOutput.Name & "'!K40", _
'                               TextToDisplay:="Grade"
    End If
Next lRow
Application.CutCopyMode = False
End Sub

 

[Mohammed Abu Hawash]

Thank you very much Alan for your help