A VBA code to create sheets based on a list

[seragrefaat]

I want to create and rename number of sheets based on values in range of cells, also after that i want to distribute each value of another list in a fixed cell, B39, of each sheet created.
I have already done the first part but i want someone to modify it to not fixed list (or range), i make the code with the range Q4:Q11, how to make the module executable when the rnge changes to Q4:Q7 or Q4:Q20? Thanks
/

Option Explicit
Sub CreateAndName6s()
    Dim c As Range
    Application.ScreenUpdating = False
    Sheets("Data").Select
    For Each c In Range("Q4:Q11")
        c.Select
        Sheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = c.Value
        Sheets("Template").Cells.Copy
        ActiveSheet.Paste
        Range("A1").Select
        Application.CutCopyMode = False
        Range("E4").Select
        ActiveSheet.Range("E4").Value = c.Value
        Sheets("Data").Select
        ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=c.Value & "!A1", TextToDisplay:=c.Value

    Next c
    Application.ScreenUpdating = True
End Sub

 

[seragrefaat]

That does not tell me what the value was when it failed. What is in the cell below 6-8

the cell is Blank.
The range from Q4:Q25 has a formula which gives the values, and when the formula is false it gives nothing. It works fine in my Code

 

[Fluff]

The range from Q4:Q25 has a formula which gives the values, and when the formula is false it gives nothing

That's a crucial bit of info you missed out & if the cell is empty then your code will also fail.
Try

Sub seragrefaat()
   Dim cl As Range
   
   Application.ScreenUpdating = False
   With Sheets("Data")
      For Each cl In .Range("Q4", .Range("Q" & Rows.Count).End(xlUp))
         If cl.Value <> "" Then
            Sheets("Template").Copy , Sheets(Sheets.Count)
            ActiveSheet.Name = cl.Value
            ActiveSheet.Range("E4").Value = cl.Value
            ActiveSheet.Range("B39").Value = cl.Offset(, 1).Value
            .Hyperlinks.Add cl, "", cl.Value & "!A1", cl.Value
         End If
      Next cl
   End With
   Application.ScreenUpdating = True
End Sub

 

[seragrefaat]

That's a crucial bit of info you missed out & if the cell is empty then your code will also fail.
Try

Sub seragrefaat()
   Dim cl As Range
  
   Application.ScreenUpdating = False
   With Sheets("Data")
      For Each cl In .Range("Q4", .Range("Q" & Rows.Count).End(xlUp))
         If cl.Value <> "" Then
            Sheets("Template").Copy , Sheets(Sheets.Count)
            ActiveSheet.Name = cl.Value
            ActiveSheet.Range("E4").Value = cl.Value
            ActiveSheet.Range("B39").Value = cl.Offset(, 1).Value
            .Hyperlinks.Add cl, "", cl.Value & "!A1", cl.Value
         End If
      Next cl
   End With
   Application.ScreenUpdating = True
End Sub

Perfect, thanks a ton,
I have more couple to ask, can i make a command button and put the code in it, and when i click the button it will trigger the code and create sheets?
Also, can i repeat the code 3 more time with column S, U, W in one code?
Last thing, the hyperlink does not work, can you modify it to activate the sheet when i click on the linked cell in sheet Data?

Thanks a lot Fluff

 

[Fluff]

In what way doesn't the hyperlink work?

 

[seragrefaat]

In what way doesn't the hyperlink work?

It gives popup error message, not valid

 

[Fluff]

Ok, try

            .Hyperlinks.Add cl, "", "'" & cl.Value & "'!A1", cl.Value

 

[seragrefaat]

Wo

Ok, try

            .Hyperlinks.Add cl, "", "'" & cl.Value & "'!A1", cl.Value

WOW, Thats great. Last thing I want to automatically return to sheet Data after the end of the code.

 

[Fluff]

Just add the part in blue

      Next cl
      .Activate
   End With

 

[seragrefaat]

Just add the part in blue

      Next cl
      .Activate
   End With

Thank you very much for your help. your work is very appreciated.

 

[Fluff]

You're welcome & thanks for the feedback.