Excel VBA - Copying template worksheet and linking cell and naming sheet

Question

I have data in column A in worksheet called "Summary". Some months it has 50 rows while other times it is 500 rows.

I have a template sheet called "Template". I would like to create a copy of "Template" sheet, name it after each row from Summary (so a loop), and then place the row cell data in cell A1 of the sheet. Finally back in Summary sheet I would like to create a hyperlink in my row pointing to the sheet.

Here is an image of what I would like it to look like:

Answer 1

After some toying around in Excel I believe this will suit your needs. Simply place into a new module and execute.

Sub CreateLinkedSheets()

    Dim rngCreateSheets As Range
    Dim oCell As Range

    Dim oTemplate As Worksheet
    Dim oSummary As Worksheet
    Dim oDest As Worksheet

    Set oTemplate = Worksheets("Template")
    Set oSummary = Worksheets("Summary")
    Set rngCreateSheets = Worksheets("Summary").Range("A1", Range("A1").End(xlDown))
    'Above line assumes NO blank cells in your list of school supplies

    For Each oCell In rngCreateSheets.Cells

        oTemplate.Copy After:=Worksheets(Sheets.Count)
        Set oDest = ActiveSheet
        oDest.Name = oCell.Value

        oDest.Range("A1").Value = oCell.Value

        oSummary.Hyperlinks.Add Anchor:=oCell, Address:="", SubAddress:= _
            oDest.Name & "!A1", TextToDisplay:=oDest.Name
    Next oCell

End Sub

I do stand by my original comment of using the macro recorder first to examine the code output and then adapting it to your needs. That's what I did to get the code for adding the hyperlink, for example.

For this code to work, your worksheets must be named "Summary" and "Template" (as in your picture) and your list in column A must be contiguous, that is to say you cannot leave any blank cells in the list. If you do the line Set rngCreateSheets = Worksheets("Summary").Range("A1", Range("A1").End(xlDown)) won't set the range properly and you'll be missing items.

Answer 2

Searching will get you a lot of answers, especially on Stackoverflow. Here are some examples of what I searched for, and maybe it'll help you.

• Searched: worksheet copy vba - how to copy and rename sheets
• Searched: loop through range - shows just that
• Searched: msgbox yes no vba - how to create yes/no boxes in vba
• Searched: check if sheets exisits - it's has the same function I used below
• Searched: vba hyperlink to sheet - how to create hyperlinks in excel w/ vba

I know an answer has been posted, but since I had something already, and it's slightly different, thought I'd post it anyways since it has some extra features which you might be able to glean from. It includes:

1. Error checking (in case a sheet of the same name exists)
2. The sub routine as a called in a separate routine while passing variables

Give it try and let me know what you think.

 Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
 'Created by Tim Williams from Stackoverflow.com
 'https://stackoverflow.com/questions/6688131/excel-vba-how-to-test-if-sheet-exists
    Dim sht As Worksheet

     If wb Is Nothing Then Set wb = ThisWorkbook
     On Error Resume Next
     Set sht = wb.Sheets(shtName)
     On Error GoTo 0
     SheetExists = Not sht Is Nothing
 End Function

Sub CreateSummarySheets(SummaryWS As Worksheet, TemplateWS As Worksheet)

    Dim newWS As Worksheet
    Dim rCell As Range
    Dim lastRow As Long
    Dim answer  As Long

    lastRow = SummaryWS.Cells(Rows.Count, "A").End(xlUp).Row

    For Each rCell In SummaryWS.Range("$A$1:$A$" & lastRow)
      'Add copy of template
        TemplateWS.Copy After:=Sheets(Sheets.Count)
        Set newWS = Sheets(Sheets.Count)

      'Sheet exists error checking
        answer = 1
        If SheetExists(newWS.Name) = False Then
            answer = vbNo
            answer = MsgBox("Sheet with the name " & rCell.Value & " already exists.  Delete it?", vbYesNo, rCell.Value & " Sheet Exists")
        End If

        If answer = vbYes Then
            Sheets(rCell.Value).Delete
        End If
        If answer = 1 Or answer = vbYes Then
            newWS.Name = rCell.Value
        End If

      'Populate newWS's cell A1
        newWS.Cells(1, "A") = rCell.Value
      'Add Hyperlink from summary to newWS
        newWS.Hyperlinks.Add Anchor:=rCell, Address:="", _
            SubAddress:="'" & newWS.Name & "'" & "!A1", TextToDisplay:=newWS.Name
    Next rCell

End Sub

Sub test()
    Dim s_ws As Worksheet
    Set s_ws = Sheets("Summary")

  'Two ways to run this function
    Call CreateSummarySheets(s_ws, Sheets("Template"))
End Sub