Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 159
  • Last Modified:

Modify macro to include links

I need to modify the existing macro to have the index create links back to the original study row.  It would also be helpful if the rows in the index could have the default alternating color fills so as to make the index easier to navigate.
Sub Create_Index()

'This code is designed to create an index file that contains 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
    
    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
                Rw = Rw + 1
            End If
        End If
    Next i
End Sub

Open in new window

tosstudies-6.15.xlsm
0
rtod2
Asked:
rtod2
  • 3
1 Solution
 
SiddharthRoutCommented:
Like this?

Sub create_Index()
    Dim lastRow As Long, Rw As Long, i As Long
    Dim ws As Worksheet
    Dim StrSearch As String
    
    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("C" & Rw), Address:="", SubAddress:= _
                "Studies!D" & i, TextToDisplay:=Sheets("studies").Range("D" & i).Value
                On Error GoTo 0
                Rw = Rw + 1
            End If
        End If
    Next i
    
    With ws.Cells
        .ColumnWidth = 170.14
        .RowHeight = 248.25
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
    End With
End Sub

Open in new window


Sid
0
 
SiddharthRoutCommented:
Oops. I forgot the coloring part.

Sub create_Index()
    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

Open in new window


Sid
0
 
rtod2Author Commented:
Unbelievable!
0
 
SiddharthRoutCommented:
Glad to be of help :)

Sid
0

Featured Post

Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now