Update fixes needed

Updates, whether in the Study tab or in the Index tab, should be correctly reflected, and next to the correct study whenever the macro is re-run.

Sub create_Index()

'This code is designed to
'1. Create an index file that contains a link to numbered title columns.
'2. Add copyright copyright information from the same row.
'3. Create empty columns that can be edited from the Index tab itself.

'Re-applying the macro when new studies are added, should still maintain this information
'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
    
    On Error Resume Next
    Set rng = ws.Range("A1:E" & lastRow)
    ws.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = "Table3"
    ws.ListObjects("Table3").TableStyle = "TableStyleMedium15"
    On Error GoTo 0
    
    With ws.Cells
        .ColumnWidth = 170.14
        .RowHeight = 248.25
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
    End With
End Sub

Select allOpen in new window

tosstudies-6.18.xlsm