VBA that copies and inserts new sheet and changes formulas

Jamidd1,
I ran through the beginning of your code. The value for N is 28, so S is looking at B28, which in your file has nothing in it, so S = nothing, so the macro exits at that point.

In your description of your problem you said "and then renames the worksheet with the text value you A1." So, I'm not sure what the problem is. Please clarify.

Sub AddNewSheet(): Dim ws As Worksheet, S As String, n As Long, i As Long, C As Range
    Dim wdd As Worksheet: Set wdd = Sheets("Student Data & Details")
    'Get new sheet name - if null then quit
    n = 7 * (Worksheets.Count - 1): S = wdd.Range("B" & n).Value
    MsgBox n
    MsgBox S
    If S = "" Then Exit Sub
    Application.EnableEvents = False    'Shut off events
    'Copy last sheet to new last place
    Set ws = Worksheets(Worksheets.Count): ws.Copy After:=Worksheets(Worksheets.Count)
    'Set and name the new sheet
    Set ws = ActiveSheet: ws.Name = S: ws.Cells.Hyperlinks.Delete
    For Each C In ws.UsedRange                      'look at every cell in new sheet
        If C.HasFormula Then                            'Cells with Formulas
            S = C.Formula: i = InStr(1, S, "!") + 1
            'it puts hyperlink in B22? - new feature?
            If IsNumeric(Right(S, Len(S) - i)) Then n = Right(S, Len(S) - i) Else GoTo GetNext
            'Going inside the formula If the ref is to Exam add 20 else add 5 to the row number
            n = IIf(InStr(1, S, "Exam"), n + 20, n + 7)
            S = Left(S, i) & n: C.Formula = S     'Reconstruct the Formula with the new row number
        End If
GetNext:         Next C         'Get the next Cell
    'Turn on Events and Quit
    Application.EnableEvents = True: End Sub

Originally Posted by jomili

Jamidd1,
I ran through the beginning of your code. The value for N is 28, so S is looking at B28, which in your file has nothing in it, so S = nothing, so the macro exits at that point.

In your description of your problem you said "and then renames the worksheet with the text value you A1." So, I'm not sure what the problem is. Please clarify.

Sub AddNewSheet(): Dim ws As Worksheet, S As String, n As Long, i As Long, C As Range
    Dim wdd As Worksheet: Set wdd = Sheets("Student Data & Details")
    'Get new sheet name - if null then quit
    n = 7 * (Worksheets.Count - 1): S = wdd.Range("B" & n).Value
    MsgBox n
    MsgBox S
    If S = "" Then Exit Sub
    Application.EnableEvents = False    'Shut off events
    'Copy last sheet to new last place
    Set ws = Worksheets(Worksheets.Count): ws.Copy After:=Worksheets(Worksheets.Count)
    'Set and name the new sheet
    Set ws = ActiveSheet: ws.Name = S: ws.Cells.Hyperlinks.Delete
    For Each C In ws.UsedRange                      'look at every cell in new sheet
        If C.HasFormula Then                            'Cells with Formulas
            S = C.Formula: i = InStr(1, S, "!") + 1
            'it puts hyperlink in B22? - new feature?
            If IsNumeric(Right(S, Len(S) - i)) Then n = Right(S, Len(S) - i) Else GoTo GetNext
            'Going inside the formula If the ref is to Exam add 20 else add 5 to the row number
            n = IIf(InStr(1, S, "Exam"), n + 20, n + 7)
            S = Left(S, i) & n: C.Formula = S     'Reconstruct the Formula with the new row number
        End If
GetNext:         Next C         'Get the next Cell
    'Turn on Events and Quit
    Application.EnableEvents = True: End Sub

If you go to student data and details tab and insert new student rows using the macro button on that tab then go to exam input data tab and use the button to insert rows on that tab. Then change the student name on the student and details tab.
If you then add the new student sheet via the button on the student details. You should then see what the issue is.
The sheet is named summer-16 instead of the new student name.

I hope this helps!
Thank you
Jamidd

Jamidd1,

I followed your directions, and DO see the "Summer-2016" sheet being created. The error occurs because of your N and S values. See the picture attached.

Your formula for determining the values is shown below. When one sheet is inserted, number of sheets is 5, minus 1 is 4, times 7 is 28. So the value from B28 is used for the worksheet name.

n = 7 * (Worksheets.Count - 1): S = wdd.Range("B" & n).Value

I think you need to change your formulation. You could do it by looking at the last value in ColumnB, and offsetting 6 rows back. See example below.

Sub AddNewSheet(): Dim ws As Worksheet, S As String, n As Long, i As Long, C As Range
    Dim wdd As Worksheet: Set wdd = Sheets("Student Data & Details")
    Dim LastRow As Long
    
    'Determine our last row
    LastRow = Range("B" & Rows.Count).End(xlUp).Row

    'Get new sheet name - if null then quit
'    n = 7 * (Worksheets.Count - 1): S = wdd.Range("B" & n).Value
    S = Range("B" & LastRow).Offset(-6, 0)
    
    MsgBox S
    If S = "" Then Exit Sub
    Application.EnableEvents = False    'Shut off events
    'Copy last sheet to new last place
    Set ws = Worksheets(Worksheets.Count): ws.Copy After:=Worksheets(Worksheets.Count)
    'Set and name the new sheet
    Set ws = ActiveSheet: ws.Name = S: ws.Cells.Hyperlinks.Delete
    For Each C In ws.UsedRange                      'look at every cell in new sheet
        If C.HasFormula Then                            'Cells with Formulas
            S = C.Formula: i = InStr(1, S, "!") + 1
            'it puts hyperlink in B22? - new feature?
            If IsNumeric(Right(S, Len(S) - i)) Then n = Right(S, Len(S) - i) Else GoTo GetNext
            'Going inside the formula If the ref is to Exam add 20 else add 5 to the row number
            n = IIf(InStr(1, S, "Exam"), n + 20, n + 7)
            S = Left(S, i) & n: C.Formula = S     'Reconstruct the Formula with the new row number
        End If
GetNext:         Next C         'Get the next Cell
    'Turn on Events and Quit
    Application.EnableEvents = True: End Sub

Thank you very much!

This works a treat! I did think it would be something to do with the calculations i just could not work out where.

Much appreciated.

Jamidd

Glad it helped. If that fixes things don't forget to mark your thread "solved".

Hi Jomili

I have noticed a glitch with looking for the last row then offsetting 6 this means if i insert more then 1 student rows on the student details and data tab, when the new sheet is created it takes the name of the last student added not the 1st of the new students added,

Please see attached work book.

I was wondering if there would be a way to combine all the following 3 VBA so when you click the insert mew student rows it adds the rows on the Student details and data worksheet, Exam data worksheet and then adds the new worksheet for the student aswell?

This would solve the issue and also save time by have to switch between worksheets to add the rows.

Thanks for your help.

Code that adds new worksheet

Sub AddNewSheet(): Dim ws As Worksheet, S As String, n As Long, i As Long, C As Range
    Dim wdd As Worksheet: Set wdd = Sheets("Student Data & Details")
    Dim LastRow As Long
    
    'Determine our last row
    LastRow = Range("B" & Rows.Count).End(xlUp).Row

    'Get new sheet name - if null then quit
'    n = 7 * (Worksheets.Count - 1): S = wdd.Range("B" & n).Value
    S = Range("B" & LastRow).Offset(-6, 0)
    
    MsgBox S
    If S = "" Then Exit Sub
    Application.EnableEvents = False    'Shut off events
    'Copy last sheet to new last place
    Set ws = Worksheets(Worksheets.Count): ws.Copy After:=Worksheets(Worksheets.Count)
    'Set and name the new sheet
    Set ws = ActiveSheet: ws.Name = S: ws.Cells.Hyperlinks.Delete
    For Each C In ws.UsedRange                      'look at every cell in new sheet
        If C.HasFormula Then                            'Cells with Formulas
            S = C.Formula: i = InStr(1, S, "!") + 1
            'it puts hyperlink in B22? - new feature?
            If IsNumeric(Right(S, Len(S) - i)) Then n = Right(S, Len(S) - i) Else GoTo GetNext
            'Going inside the formula If the ref is to Exam add 20 else add 5 to the row number
            n = IIf(InStr(1, S, "Exam"), n + 20, n + 7)
            S = Left(S, i) & n: C.Formula = S     'Reconstruct the Formula with the new row number
        End If
GetNext:         Next C         'Get the next Cell
    'Turn on Events and Quit
    Application.EnableEvents = True: End Sub

Option Explicit

Code that Adds new rows on the student details and data worksheet
Sub InsertRows()

    Const sROWS_TO_COPY As String = "10:16"

    Dim vNoOfStudents   As Variant
    Dim iNoOfStudents   As Integer
    Dim iStudentNo      As Integer
    Dim rLastRow        As Range
    Dim wks             As Worksheet

    vNoOfStudents = InputBox("How many new students should be addeded?", "How many")

    If IsNumeric(vNoOfStudents) Then

        iNoOfStudents = CInt(vNoOfStudents)

        If iNoOfStudents > 0 Then

            Set wks = ActiveSheet

            Set rLastRow = wks.Rows.Find("*", , , , xlByRows, xlPrevious)

            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

                For iStudentNo = 1 To iNoOfStudents

                    Application.StatusBar = "Adding Student No " & iStudentNo & " . . ."

                    With wks
                        .Rows(sROWS_TO_COPY).Copy
                        rLastRow.Offset(1, 0).EntireRow.Insert
                    End With

                Next iStudentNo

                Application.StatusBar = False

            Application.Calculation = xlCalculationAutomatic
            Application.ScreenUpdating = True

            Application.CutCopyMode = False

        End If

    End If

End Sub

Code that inserts rows on Exam data input worksheet

Sub InsertRows(): Dim R As Range
Set R = Rows.Find("*", , , , xlByRows, xlPrevious)
With ActiveSheet
.Rows("4:23").Copy
R.Offset(1, 0).EntireRow.Insert
End With
Application.CutCopyMode = False
l = Range("A" & Rows.Count).End(xlUp).Row - 19
Range("A" & l).Resize(20).Formula = "='Student Data & Details'!$B$" & ((l - 4) / 20) * 7 + 10
End Sub

I'm surprised you didn't notice MORE glitches. You have two macros with the same name ("InsertRows"), which usually leads to a fault. I don't see a big issue with combining these three, but need to know the order of events. I'm assuming the process starts with your user clicking the "InsertNewStudentRows" button on the "Student Data & Details" tab, which runs your FIRST "InsertRows" macro, then when that process finishes you go to the "Exam Data Input" and click on the "Insert New Student Rows" button, which runs your OTHER "InsertRows" macro, then you go back to the "Student Data & Details" tab and click the "Add new Student Sheet" button. Is that the right order of events?

I'm working on another project right now, but will get back to this as quickly as I can once you clarify.

Originally Posted by jomili

I'm surprised you didn't notice MORE glitches. You have two macros with the same name ("InsertRows"), which usually leads to a fault. I don't see a big issue with combining these three, but need to know the order of events. I'm assuming the process starts with your user clicking the "InsertNewStudentRows" button on the "Student Data & Details" tab, which runs your FIRST "InsertRows" macro, then when that process finishes you go to the "Exam Data Input" and click on the "Insert New Student Rows" button, which runs your OTHER "InsertRows" macro, then you go back to the "Student Data & Details" tab and click the "Add new Student Sheet" button. Is that the right order of events?

I'm working on another project right now, but will get back to this as quickly as I can once you clarify.

Hi Jomili,

I was just wondering if you had any chance to look into this yet?

Thanks

Jamidd

I thought that would have been a problem but it never seemed to get in the way so i did not get round to changing it if i am honest.

You are correct in thinking that is the process!

Im guessing there will have to be a way for the person to enter the student name at some point so the new student worksheet can be created.

That is absolutely fine whenever you get a chance!

Thank you

Jamidd

Thank you very much! This works like a charm as far as i can see!

I was wondering i have my version of this with locked cells etc will this easily paste into my version of this workbook everything is the same apart from some locked cells and some other small changes.

Thanks Again

Jamidd

Locked cells only apply if you protect the worksheet. If you want to keep the worksheets protected all we need to do is write in a routine that unlocks the worksheets at the beginning of the process and relocks them at the end. Easy to do it you need it. See the link: http://analysistabs.com/excel-vba/pr...ct-worksheets/

I'm leaving for the day and won't be back on the computer until late in the morning tomorrow, so don't expect any other replies from me today.

Originally Posted by jomili

Locked cells only apply if you protect the worksheet. If you want to keep the worksheets protected all we need to do is write in a routine that unlocks the worksheets at the beginning of the process and relocks them at the end. Easy to do it you need it. See the link: http://analysistabs.com/excel-vba/pr...ct-worksheets/

I'm leaving for the day and won't be back on the computer until late in the morning tomorrow, so don't expect any other replies from me today.

Hi jomili,
Thank you for your reply!
I understand how the codes work in the link you provided but cant figure out where I need to put the code to unprotect and then protect again jn this process.

The reason I need this is no formulas are not lost by accident when other users are using the document, so that they can only edit certain cells.
Thanks

Jamidd

See attached. I commented the protection code so you can see where it kicks in and out. Password in the code and in the workbook is 1234; change to whatever you want it to be.

Sub AddNewStudent()
    Const sROWS_TO_COPY As String = "10:16"
    Dim vNoOfStudents As Variant
    Dim iNoOfStudents As Integer
    Dim iStudentNo As Integer
    Dim rLastRow As Range
    Dim Rng As Range
    Dim PasteRng As Range
    Dim WS As Worksheet
    Dim NewName As String

    'Check to make sure we're on the right sheet to start
    If Not ActiveSheet.Name = "Student Data & Details" Then Sheets("Student Data & Details").Activate

    vNoOfStudents = InputBox("How many new students should be addeded?", "How many?")

    If IsNumeric(vNoOfStudents) Then
        iNoOfStudents = CInt(vNoOfStudents)
        If iNoOfStudents > 0 Then
            Set WS = ActiveSheet
            WS.Unprotect "1234"   'Removes the password
            Sheets("Exam Data Input").Unprotect "1234"    'Removes the password
            
            Set rLastRow = WS.Rows.Find("*", , , , xlByRows, xlPrevious)

            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            For iStudentNo = 1 To iNoOfStudents
                Application.StatusBar = "Adding Student No " & iStudentNo & " . . ."
                NewName = Application.InputBox("What is the name for new student #" & iStudentNo & "?", "Input Student Name", , 10, 10, , , 2)
                Set WS = Sheets("Student Data & Details")
                With WS
                    Set rLastRow = WS.Rows.Find("*", , , , xlByRows, xlPrevious)
                    .Rows(sROWS_TO_COPY).Copy
                    .Paste Destination:=rLastRow.Offset(1, 0).EntireRow
                    rLastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
                    .Range("B" & rLastRow).Offset(-6, 0).Value = NewName
                End With

                AddNewSheet

                'Now let's set up the Exam Data sheet
                Sheets("Exam Data Input").Activate
                Set WS = ActiveSheet
                
                Set rLastRow = WS.Rows.Find("*", , , , xlByRows, xlPrevious)

                With WS
                    .Rows("4:23").Copy
                    .Paste Destination:=rLastRow.Offset(1, 0)    '.EntireRow
                    Application.CutCopyMode = False
                    l = .Range("A" & Rows.Count).End(xlUp).Row - 19
                    Set PasteRng = .Range("A" & l).Resize(20)
                    For Each Rng In PasteRng
                        Rng.Formula = "='Student Data & Details'!$B$" & ((l - 4) / 20) * 7 + 10
                        If Not Rng.Interior.ColorIndex = -4142 Then
                            Rng.Hyperlinks.add Anchor:=Rng, Address:="", SubAddress:=NewName & "!A1", TextToDisplay:=NewName
                            With Rng.Font
                                .ThemeColor = xlThemeColorDark1
                                .TintAndShade = 0
                                .ThemeFont = xlThemeFontNone
                            End With
                        End If
                    Next Rng
                End With
                
                'Now let's set the hyperlinks on our starting page
                Sheets("Student Data & Details").Activate
                rLastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
                ActiveSheet.Range("B" & rLastRow).Offset(-6, 0).Hyperlinks.add Anchor:=Selection, Address:="", SubAddress:=NewName & "!A1", TextToDisplay:=NewName
            Next iStudentNo


            'All done; let's protect it all again
            ActiveSheet.Protect "1234", True, True  'Protects with password
            Sheets("Exam Data Input").Protect "1234", True, True  'Protects with password
            Application.StatusBar = False

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

End Sub

I did NOT add any protection to the new Student Sheet. If you want to protect that sheet, you just need to add the protection code after "Get the next Cell" and before "Turn on Events and Quit"

Thanks this is great! Although I have resorted to using the one without the protection!

I have one question regarding Cell A1 on the student sheet that names the worksheet. Is there a way to make that be referenced to the student name in the student details and data tab so if the student name needs to be change on the student details and data worksheet for any reason this changes without me needing to do it manually.

='Student Data & Details'!B10

It does not paste the formula when it finds the students name it just pastes the value.

Sorry for the late reply I have only just had a chance to play around with it.

Thank you for all your help so far.

James

We could do that, but if we did then the student name in A1 wouldn't match the Tab name, so you'd still have to do a manual change to change the tab name.

Originally Posted by jomili

We could do that, but if we did then the student name in A1 wouldn't match the Tab name, so you'd still have to do a manual change to change the tab name.

That would be fine! If that can be done. Its just incase I need to change a students name for any reason.
Thanks
James