[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

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

Modify macro to edit header row in Index tab

Index tab should contain the following header row.

Column A:  Study #
Column B:  Name of Study
Column C:  Notes from Study tab
Column D:  Notes for Index
Column E:  Notes for Index

Attached is the code and the file.
Sub Create_or_Update_Index()

'This code is designed to
'1. Create an index file that contains a link to each numbered study.
'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, or when comments are added to either sheet
'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
                
                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
            Else
                acell.Offset(, 2).Value = Sheets("studies").Range("D" & i).Value
            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

tosstudies-6.19.xlsm
0
rtod2
Asked:
rtod2
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
    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

    ws.Cells(1, 1) = "Study #"
    ws.Cells(1, 2) = "Name of Study"
    ws.Cells(1, 3) = "Notes from Study tab"
    ws.Cells(1, 4) = "Notes for Index"
    ws.Cells(1, 5) = "Notes for Index"
        
    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
                
                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
            Else
                acell.Offset(, 2).Value = Sheets("studies").Range("D" & i).Value
            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
 
rtod2Author Commented:
Exceptional as always!
0

Featured Post

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

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