Creating Index Items with Dynamic Hyperlinks to Cells in Workbook

[vanhunk]

I am trying to create code to add the contents of the cell active when executing the macro. I have succeeded in doing it (see code below) but have the following issues:

This Macro Code creates a new item in the index, displaying the value of the cell active when launching the macro and creating a hyperlink to it.

WHEN THE POSITION OF THE ORIGINAL DATA CHANGES, I.E. LINES OR COLUMNS ARE DELETED OR INSERTED, HE HYPERLINKS CREATED ARE NO LONGER APPLICABLE.
1) HOW CAN I MAKE THESE HYPERLINKS DYNAMIC?
2) CAN I MAKE THE CODE SIMPLER, I.E. NOT USE "SELECT" AND
"SELECTION" IN THE CODE? _
3) HOW CAN I PREVENT ACCIDENTALLY ADDING DUPLICATE ENTRIES TO
THE INDEX?
4) WHAT IS THE BEST WAY TO SORT THE LIST?


Sub IndeksVanSelItems()
'This Macro Code creates a new item in the index, displaying the value of the cell active _
when launching the macro and creating a hyperlink to it:
'WHEN THE POSITION OF THE ORIGINAL DATA CHANGES, I.E. LINES OR COLUMNS ARE DELETED OR INSERTED, _
THE HYPERLINKS CREATED ARE NO LONGER APPLICABLE. _
1) HOW CAN I MAKE THESE HYPERLINKS DYNAMIC? _
2) CAN I MAKE THE CODE SIMPLER, I.E. NOT USE "SELECT" AND "SELECTION" IN THE CODE? _
3) HOW CAN I PREVENT ACCIDENTALLY ADDING DUPLICATE ENTRIES TO THE INDEX? _
4) WHAT IS THE BEST WAY TO SORT THE LIST?

Dim NuweItemRy As Long 'The first empty row in the index.
With Sheets("Indeks")
NuweItemRy = .Cells(.Rows.Count, Range("INDEKS").Column).End(xlUp).Row + 1
End With
Dim LinkOpskrif As String 'The heading of the link, i.e. the value in the starting active cell.
Dim LinkSheet As String 'The sheet the link refers to.
Dim LinkSel As String 'The address of the cell the link refers to.
Dim LinkAdres As String 'The full address of the cell the link refers to.
LinkOpskrif = ActiveCell.ValueLinkSheet = ActiveSheet.Name
LinkSel = ActiveCell.Address
LinkAdres = LinkSheet & "!" & LinkSel
'Adding the selected item to the index and creating the hyperlink:
'IS THERE A WAY TO DO THIS WITHOUT USING "SELECT" AND "SELECTING" IN THE CODE BELOW?


Sheets("Indeks").Select
Cells(NuweItemRy, Range("INDEKS").Column).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
LinkAdres, TextToDisplay:=LinkOpskrif
End Sub

I went through many posts and could not get a problem that does exactly this and would really appreciate your support.

Thanks in anticipation.

[snb]

Sub M_snb()
For Each cl In Sheets("source").Columns(2).SpecialCells(2)
cl.Name = Replace(cl.Value, " ", "_")
Sheets("indeks").Hyperlinks.Add Sheets("indeks").Cells(Rows.Count, 5).End(xlUp).Offset(1), "", Replace(cl.Value, " ", "_"), , cl.Value
Next
End Sub

[SamT]

snb writes the tightest code of anyone I've seen. I often study his examples to further my own knowledge. Here is my analysis of his example. Note that it is specific to your upload.


Sub M_snb()
Dim Cel As Range
'SpecialCells Types: 2 = xlCellTypeFormulas
For Each Cel In Sheets("Source").Columns(2).SpecialCells(2)
'Define a Name for the Cell the index links to. Change " " to "_"
Cel.Name = Replace(Cel.Value, " ", "_")
'Create the link
Sheets("indeks").Hyperlinks.Add _
'Where to place the Hyperlink = next empty cell in Column "E"
Sheets("indeks").Cells(Rows.Count, 5).End(xlUp).Offset (1), _
"", Replace(Cel.Value, " ", "_"), , Cel.Value
''''Analyze Hyperlink code
'Address:= "" [Leave empty]
'Subaddress:=Replace(Cel.Value, " ", "_") [Range Name]
'Screen Tip:= Nothing
'Txt to display:=Cel.Value
Next
End Sub

[snb]

@SamT
Your interpretation of the specialcells isn't correct: specialcells(-4123) =specialcells(xlcelltypeformulas)



Sub M_snb()
For Each cl In Sheets("source").Columns(2).SpecialCells(2) ' every cell in sheet 'source' in colum 'B' that contains text or a number
cl.Name = Replace(cl.Value, " ", "_") ' define that cell as a named range; it's name being the value in the cell, from which the spaces have been _
replaced by an underscore since defined names can't contain spaces
Sheets("indeks").Hyperlinks.Add Sheets("indeks").Cells(Rows.Count, 5).End(xlUp).Offset(1), "", Replace(cl.Value, " ", "_"), , cl.Value _
' add a hyperlink in sheet 'indeks' in the first empty cell in column 'E'; parameters: address="", subaddress=the name of the named range, _
no screentip, displaytext=the cell value in column 'B' in sheet 'source'
Next
End Sub

[SamT]

snb,

My bad.:whip

I misread x while stepping thru
Sub test()
Dim x
x = xlCellTypeAllFormatConditions ' Cells of any format
x = xlCellTypeAllValidation 'Cells having validation criteria
x = xlCellTypeBlanks 'Empty Cells
x = xlCellTypeComments 'Cells containing notes
x = xlCellTypeConstants 'Cells containing constants
x = xlCellTypeFormulas 'Cells containing formulas
x = xlCellTypeLastCell 'The last cell in the used range
x = xlCellTypeSameFormatConditions ' Cells having the same format
x = xlCellTypeSameValidation ' Cells having the same validation criteria
x = xlCellTypeVisible
End Sub I read x while xlcelltypeformulas was highlighted, which is before it executes.

I'm very surprised that you don't use system constants in your code.

[snb]

I'm very surprised that you don't use system constants in your code.

If you design multi application code (using Word, Outlook, Excel, Access and/or Powerpoint) and if you use late binding, the system contstants won't be recognised, while the indexnumbers will.

[SamT]

Tks, good to know.

[vanhunk]

snb,

Thank you so much for your quick reply and excellent code, I truly believe you are a master and appreciate your replies immensely!

SamT,
Thank you for your comments, although snb's code is always very neat and tight, I often find it hard to understand it fully.

I modified the code of snb (see below) and that gave me what I was looking for.

Thanks again


Sub M_snbModified()
ActiveCell.Name = Replace(ActiveCell.Value, " ", "_")
Sheets("indeks").Hyperlinks.Add Sheets("indeks").Cells(Rows.Count, 2).End(xlUp).Offset(1), "", Replace(ActiveCell.Value, " ", "_"), , ActiveCell.Value
End Sub

[SamT]

If you design multi application code (using Word, Outlook, Excel, Access and/or Powerpoint) and if you use late binding, the system contstants won't be recognised, while the indexnumbers will.

I looked into this over the weekend. Several experts think one should use early binding in the design and testing phase, but convert to late binding before deployment. I also ran across a couple of Enumerated_Constants files for the major MS applications.

The idea behind them was to keep the early binding Constant in the late binding code and provide the required Enumerations so the code would work either way.

I am interested in hearing your thoughst about this.

Regards,
SamT

[snb]

I prefer the most robust method that works in early binding as well as in late binding: i.e. the use of indexnumbers. No extra provisions required.

[SamT]

snb,

Thanks for taking the time. With help from people like you, I might someday beat some knowledge into this rock I use for a brain.

SamT

[snb]

That's the spirit ! :yes

[bonayre]

THx its very usefull:eek:

[Simon Lloyd]

There's a newsletter here http://www.thecodecage.com/forumz/c_news_letter.php?issueid=4 where Zack Barresse has donated an article on creating an automated table of contents, studying that may help you further :)

[vanhunk]

Thanks guys, with your help I ended up with the following, and might I say, very useful code. Snb you would most probably be able to make it shorter. It works great!

Thanks again!


Sub Create_Index()
'This Code adds items to an index on an index sheet. It also dynamically links the index items to the original item.
'If the index sheet doesn't exist, it is created.
'It also deletes duplicate entries, deleting the oldest entries first. Therafter the list is sorted alphabetically.
'The name of the index sheet, as well as the heading of the index is determined by the user. Once it is changed the
'new name(s) will become the default name(s).
'The macro is activated after selecting the item that must be added to the index.
Dim wsSheet As Worksheet 'Used in the section that tests for the existance of the index sheet.
Dim X As Long 'Used in the section that removes all duplicate items from the index.
Dim LastRow As Long 'Used in the section that removes all duplicate items from the index.
Dim BeginSel As Range 'Used to store the address of the starting cell.
Dim BeginSheet As Worksheet 'Used to store the name of the starting sheet.
Dim Default As String 'Used for naming the index sheet.
Dim Heading As String 'Used for naming the heading of the index.
Application.ScreenUpdating = False
'ADD OR CHANGE THE DEFINED NAME FOR THE INDEX SHEET:
On Error Resume Next
If IsEmpty(ActiveWorkbook.Names("DefaultWaarde")) Then '...Check if the default index sheet name exists
ActiveWorkbook.Names.Add Name:="DefaultWaarde", RefersToR1C1:="INDEKS"
On Error GoTo 0 '...Reset error checking behaviour
Else
'MsgBox "DefaultWaarde does exist."
End If
Default = ThisWorkbook.Names("DefaultWaarde").RefersTo '...Variable used for the index sheet name
Default = Mid(Default, 3, Len(Default) - 3)
'ADD OR CHANGE THE DEFINED NAME FOR THE INDEX HEADING:
On Error Resume Next
If IsEmpty(ActiveWorkbook.Names("DefaultOpskrif")) Then '...Check if the default index name exists
ActiveWorkbook.Names.Add Name:="DefaultOpskrif", RefersToR1C1:="INDEKS"
On Error GoTo 0 '...Reset error checking behaviour
Else
'MsgBox "DefaultOpskrif does exist."
End If
DefaultHeading = ThisWorkbook.Names("DefaultOpskrif").RefersTo '...Variable used for the index name
DefaultHeading = Mid(DefaultHeading, 3, Len(DefaultHeading) - 3) '...Remove extra characters
' CAPTURE THE CELL AND SHEET OF THE SELECTED ITEM:
Set BeginSel = ActiveCell '...Starting cell
Set BeginSheet = Application.ActiveSheet '...Starting sheet
If IsEmpty(BeginSel) Then Exit Sub '...Exist if the selected cell is empty
' CHECKING IF INDEX SHEET EXISTS AND ADDING ONE IF IT DOESN'T:
' Decide on a name for the index sheet, default is "INDEKS":
wsNaam = InputBox("Name of the sheet?", "Nuwe Naam/Index Sheet", Default)
If wsNaam = "" Then '...Early exit if cancel is pressed
MsgBox "Cancel Pressed"
Exit Sub
Else
End If
ActiveWorkbook.Names.Add Name:="DefaultWaarde", RefersToR1C1:=wsNaam
' Test if index sheet exists:
On Error Resume Next
' If a sheet with the chosen name does not exist, the following line would yield an error, therfore the use of
' On Error Resume Next. If it does exist wsSheet will be equated to it.
Set wsSheet = Sheets(wsNaam) '...If the sheet does exist wsSheet will be equated to it.
On Error GoTo 0 '...Reset error checking behaviour
'If the worksheet does exist, execute following code:
If Not wsSheet Is Nothing Then
'MsgBox "I do exist"
' CHECKING IF INDEX HEADING NAME EXISTS AND ADDING ONE IF IT DOESN'T:
' Decide on a name for the index heading, default is "INDEKS":
Heading = InputBox("Index Heading?", "IndeksNaam/Index Name", DefaultHeading)
If Heading = "" Then '...Early exit if cancel is pressed
MsgBox "Cancel Pressed"
Exit Sub
Else
End If
ActiveWorkbook.Names.Add Name:="DefaultOpskrif", RefersToR1C1:=Heading
wsSheet.Range("B2").Name = "INDEKS" '...Name the Range("B2") as "INDEKS"
Range("INDEKS").Value = Heading '...Put the heading name in Range("INDEKS")
'If the worksheet does not exist, execute following code:
Else
Sheets.Add.Name = wsNaam '...Add a Sheet named as selected earlier.
Set wsSheet = Sheets(wsNaam) '...If the sheet does exist wsSheet will be equated to it.
' Decide on a name for the index heading, default is "INDEKS":
Heading = InputBox("Index Heading?", "IndeksNaam/Index Name", DefaultHeading)
wsSheet.Range("B2").Name = "INDEKS" '...Name the Range("B2") as "INDEKS"
Range("INDEKS").Value = Heading '...Put the heading name in Range("INDEKS")
With Range("INDEKS").Font '...Format the heading
.Bold = True
.Size = 12
End With
End If
' END OF CHECKING IF INDEX SHEET EXISTS AND ADDING ONE IF IT DOESN'T
' ADD SELECTED ITEM TO THE BOTTOM OF THE INDEX LIST:
'Name the Range, i.e. name the Cell:
'The following line removes all the unwanted characters, i.e. " ", "?", ":", ";", "/", ")", "(", "-", "*", and "&".
BeginSel.Name = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Rep lace _
(BeginSel.Value, ")", "_"), "/", "_"), "*", "_"), " ", "_"), "(", "_"), "&", "_"), "-", "_"), _
":", "_"), ";", "_"), "?", "_")
'Add selected item as a hyperlink to the bottom of the index list:
Sheets(wsNaam).Hyperlinks.Add Sheets(wsNaam).Cells(Rows.Count, Range("INDEKS").Column). _
End(xlUp).Offset(1), "", _
Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Rep lace _
(BeginSel.Value, ")", "_"), "/", "_"), "*", "_"), " ", "_"), "(", "_"), "&", "_"), _
"-", "_"), ":", "_"), ";", "_"), "?", "_"), , BeginSel.Value
' DETERMINE WHETHER THE DUPLICATE MUST BE REMOVED FROM THE LIST AND THE LIST SORTED ALPHABETICALLY:
' If the new entry is the first in the list, no removal of duplicates or sorting applicable:
If IsEmpty(ThisWorkbook.Worksheets(wsNaam).Range("INDEKS").Offset(2, 0)) Then GoTo Einde
' If there are more than one entry, should the list be sorted?
Answer = MsgBox("Do you want to REFRESH the INDEX LIST?", _
vbYesNo + 256 + vbQuestion, "Refresh Index List")
If Answer = vbNo Then GoTo Einde
' REFRESH LIST:
'REMOVE DUPLICATES FROM THE LIST - START WITH THE OLDEST ITEMS, I.E. FROM THE TOP DOWN:
'Initialise the top of the list:
X = Worksheets(wsNaam).Range("INDEKS").Row + 1
'Initialise the bottom of the list:
LastRow = Worksheets(wsNaam).Range("INDEKS", Range("INDEKS").End(xlDown)).Count + 1
If X = LastRow Then GoTo Einde '...No duplicates and nothing to sort.
TelSel:
'Initialise/set the range to be used for searching and removing of duplicates:
Set SoekRange = Worksheets(wsNaam).Range(Worksheets(wsNaam).Cells(X, Range("INDEKS").Column), Worksheets(wsNaam).Cells(LastRow, Range("INDEKS").Column))
'Check for and delete duplicates, one by one:
If Application.CountIf(SoekRange, Worksheets(wsNaam).Cells(X, Range("INDEKS").Column).Text) > 1 Then
Worksheets(wsNaam).Cells(X, Range("INDEKS").Column).Delete Shift:=xlUp
LastRow = LastRow - 1 '...Move the bottom of the search range one up, since an item has been
' deleted.
If LastRow = X Then GoTo Sorteer '...If there is no more items go to the section for sorting of the list.
GoTo TelSel '...Go back to check if there are still more entry.
Else: X = X + 1 '...Move the top of the search range down by one.
If X = LastRow Then GoTo Sorteer '...If there is no more items go to the section for sorting of the list.
GoTo TelSel
' END OF REMOVING DUPLICATES
' SORT LIST ALPHABETICALLY:
Sorteer:
' Sort the remaining items alphabetically:
Worksheets(wsNaam).Range("INDEKS", Range("INDEKS").End(xlDown)).Sort Key1:=Range("INDEKS").Offset(1, 0), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
' END OF SORTING LIST ALPHABETICALLY
' Format the index list column:
With Worksheets(wsNaam)
.Columns("B:B").EntireColumn.AutoFit
.Range("INDEKS").HorizontalAlignment = xlCenter
End With
Einde:
Application.ScreenUpdating = True
' Return to the original cell:
BeginSheet.Select
BeginSel.Select
End If
End Sub

[snb]

I would use:


Sub M_snb()
If [iserror(indeks!A1)] Then Sheets.Add.Name = "indeks"
Sheets("indeks").Cells(1, 2) = "Index"
For Each cl In Sheets("Testdata").Columns(4).SpecialCells(2)
Sheets("indeks").Hyperlinks.Add Sheets("indeks").Cells(Rows.Count, 2).End(xlUp).Offset(1), "", "#" & cl.Parent.Name & "!" & cl.Address, "", cl.Value
Next
End Sub

It's shorter, easier & faster than my first suggestion.
There's no need to use any named range.

[vanhunk]

Thanks snb,

You are the best!

:thumb

[SamT]

snb,

I'm putting that in my Personal.xls, but I'm changing
For Each cl In Sheets("Testdata").Columns(4).SpecialCells(2) to
For Each cl In Sheets("Testdata").Columns(4).SpecialCells(2, 2)
since I often have lists of number constants and wouldn't want to index each individual number.

[snb]

I wouldn't mix strings and numbers in 1 column, but if you can't resist you are rigth to make that distinction.
An index of numbers can be reasonable too.

[vanhunk]

snb,

Unfortunately, by not using named ranges like in your first suggestion, the link does not not move with the source, which is a requirement.

vanhunk

[SamT]

vanhunk,

Just off the top of my head, but this might give you some ideas
For Each cl In Sheets("Testdata").Columns(4).SpecialCells(2)
X = Sheets("Testdata").Names.Add(Sheets("Testdata").Cells(Rows.Count, 2).End(xlUp).Offset(1), "", "#" & cl.Parent.Name & "!" & cl.Address, "", cl.Value )
Sheets("indeks").Hyperlinks.Add Sheets("indeks").Cells(Rows.Count, 2).End(xlUp).Offset(1), "", "#" & cl.Parent.Name & "!" & X, "", cl.Value



snb,
Construction estimators:
2x4 | 2x6
8 | 8
10 | 10
12 | etc
14
16
22

[vanhunk]

Thanks Sam

[snb]

I'd prefer:
Sub M_snb()
If [iserror(indeks!A1)] Then Sheets.Add.Name = "indeks"
Sheets("indeks").Cells(1, 2) = "Index"

For Each cl In Sheets("Testdata").Columns(4).SpecialCells(2)
cl.Name = "_" & cl.Address(0, 0)
Sheets("indeks").Hyperlinks.Add Sheets("indeks").Cells(Rows.Count, 2).End(xlUp).Offset(1), "", "_" & cl.Address(0, 0), "", cl.Value
Next
End Sub

[SamT]

Elegant and eliminates possibility of multi-word names. The multi-word name problem is why I had assigned the range name to X.