link cell formula or code to paste link across

Sub AddLinks()
    Dim srcWbk As Workbook, dstWbk As Workbook
    Dim srcWsh As Worksheet, dstWsh As Worksheet
    Dim i As Integer, j As Integer
    Dim s As String

    On Error GoTo Err_AddLinks

    Set srcWbk = ThisWorkbook
    Set srcWsh = srcWbk.Worksheets("Sheet1")
    Set dstWbk = Application.Workbooks("student")

    For i = 1 To dstWbk.Worksheets.Count
        Set dstWsh = dstWbk.Worksheets(i)
        If dstWsh.Name <> "Sheet1" Then
            s = "=Sheet1!B" + CStr(i + 2) 'This strange formula based on OP notes
            dstWsh.Range("B2").Formula = s
        End If
    Next

Exit_AddLinks:
    On Error Resume Next
    Set srcWbk = Nothing
    Set srcWsh = Nothing
    Set dstWbk = Nothing
    Set dstWsh = Nothing
    Exit Sub

Err_AddLinks:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_AddLinks

End Sub

Private Sub Workbook_NewSheet(ByVal Sh As Object)

    On Error GoTo Err_NewSheet

    'Note that Worksheets.Count has already been incremented for the new sheet
    s = "Sheet1!B" + CStr(ThisWorkbook.Worksheets.Count + 2)
    Sh.Range("B2").Formula = "=" & s
    Exit Sub

Err_NewSheet:
    MsgBox Err.Description, vbExclamation, Err.Number
End Sub