rtod2
asked on
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.
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
tosstudies-6.19.xlsm
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER