Position title row at top after clicking hyperlink

The index in the attached sheet links to the title of each study.  The only problem now is that it appears at the bottom as opposed to the top.  I am trying to prevent the need for scrolling after clicking the hyperlink.  Assistance is greatly appreciated.  Attached below is the file and pasted below is the code.

Sub create_Index()

'This code is designed to create an index file that contains a link to numbered title columns
'and a copyright column derived from the Studies tab.
'It also should create empty columns that can be edited from the Index tab itself.
'Re-applying the macro when new studies are added, should still maintain the position of the comments
'next to the correct study.

    Dim lastRow As Long, Rw As Long, i As Long
    Dim ws As Worksheet
    Dim StrSearch As String
    Dim rng As Range
   
    On Error Resume Next
    Set ws = Sheets("Index")
    On Error GoTo 0
   
    If ws Is Nothing Then
        Set ws = Sheets.Add
        ws.Name = "Index"
    End If

    Rw = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
    lastRow = Sheets("studies").Range("A" & Rows.Count).End(xlUp).Row
   
    For i = 3 To lastRow
        If Len(Trim(Sheets("studies").Range("A" & i).Value)) <> 0 Then
            StrSearch = Sheets("studies").Range("A" & i).Value
           
            Set aCell = ws.Range("A1:A" & Rw).Find(What:=StrSearch, LookIn:=xlValues, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
           
            If aCell Is Nothing Then
                ws.Range("A" & Rw).Value = Sheets("studies").Range("A" & i).Value
                ws.Range("B" & Rw).Value = Sheets("studies").Range("B" & i).Value
                ws.Range("C" & Rw).Value = Sheets("studies").Range("D" & i).Value
                On Error Resume Next
                ws.Hyperlinks.Add Anchor:=ws.Range("B" & Rw), Address:="", SubAddress:= _
                "Studies!B" & i, TextToDisplay:=Sheets("studies").Range("B" & i).Value
                On Error GoTo 0
                Rw = Rw + 1
            End If
        End If
    Next i
   
    lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
   
    Set rng = ws.Range("A1:E" & lastRow)
    ws.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = "Table3"
    ws.ListObjects("Table3").TableStyle = "TableStyleMedium15"
   
    With ws.Cells
        .ColumnWidth = 170.14
        .RowHeight = 248.25
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
    End With
End Sub

Select allOpen in new window

tosstudies-6.16.xlsm