Position title row at top after clicking hyperlink

Posted on 2011-04-21
Last Modified: 2012-05-11
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
    End With
End Sub

Open in new window

Question by:rtod2
    LVL 30

    Accepted Solution

    I thought it was not possible but after trying finally figured it out.

    This code gas to go to the sheet code area of Sheet "Studies"

    Private Sub Worksheet_Activate()
        ActiveWindow.ScrollRow = ActiveCell.Row
    End Sub

    Open in new window


    LVL 30

    Expert Comment

    Here is a snapshot.


    Featured Post

    Better Security Awareness With Threat Intelligence

    See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

    Join & Write a Comment

    I was working on a PowerPoint add-in the other day and a client asked me "can you implement a feature which processes a chart when it's pasted into a slide from another deck?". It got me wondering how to hook into built-in ribbon events in Office.
    This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
    This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.
    This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

    728 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    24 Experts available now in Live!

    Get 1:1 Help Now