Solved: Hyperlinking problem

[dalea]

: pray2: I've attached a file that will hopefully show what my problem is.

I'm showing only enough of the data to make clear my problem. Basically, I have a database of internally generated records from our real estate database. Imported into this database are some records that are parts of apartment complexes, which would also show unit number and complex name. Please note that these are already imported as linked information from an enterprise database. The data from our database, which has no unit number nor a complex name, the parcel number is not hyperlinked.


I would like to convert them all to hyperlinked data. The location of the external database is as follows:

[dalea]

I'm sorry the link apparently has to be quoted or it is active. The location of the database is as follows: "http://gisweb.clacogov.com/maps/index.html?p="
hope this one goes through.

[mancubus]

hi.
below code inserts hyperlinks to cells, if not exists, with given URL and cell value, starting from row 2... (Sheet1, ColumnA)


Private Function GetHyperAddy(Cell As Range) As String
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=227
'Function purpose: To return a hyperlink address if one exists
'Assigns a value of "None" to the string if no hyperlink is present

On Error Resume Next
GetHyperAddy = Cell.Hyperlinks.Item(1).Address
If Err.Number <> 0 Then GetHyperAddy = "None"
On Error GoTo 0

End Function



Sub InsHypLnkIfNone()
'http://vbaexpress.com/forum/showthread.php?t=41274

Dim ws As Worksheet
Dim cll As Range, rng As Range
Dim LastRow As Long
Dim HyperText As String, strUrl As String

With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With

strUrl = "http://gisweb.claycogov.com/maps/index.html?p="

Set ws = Worksheets("Sheet1")
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A2:A" & LastRow)
End With

On Error Resume Next
For Each cll In rng
HyperText = GetHyperAddy(cll)
If HyperText = "None" Then
cll.Hyperlinks.Add cll, strUrl & cll.Value
End If
Next cll
On Error GoTo 0

With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With

End Sub

[dalea]

Mancubus,

Thank you for your quick reply. It works great and faster than the speed of light. I do have an additional request, though, and a question.

The question first. The font before running your macro is "Arial 10". For the life of me I can't find in your code anywhere that you change or manipulate font size. This won't always run with Arial 10 so I would like it to run without changing the font size and name. I'm sure I'm going to get a little education, here so don't pull any punches.

The request is that the column that I would need to convert could be in any column. I supplied a stripped down version for submission to the forum. I would like it to take the beginning column and beginning row from wherever I have the cursor parked when I start the macro. Also it won't always be "worksheet 1" can it be coded with whatever sheet is the active sheet when the program is started. Would I then put the code into a module rather that a worksheet?

:bow: Again, many thanks! My biggest problem was the smallest part of your macro. I couldn't figure out how to recognize a link and do nothing except go to the next line. I'm really leaning useful skills here so be assured that your efforts are appreciated.

[mancubus]

you're wellcome dalea.

it's weird that the font size increases.
i did it manually and duplicated the problem.

when tested with another file, no problem.

[mancubus]

the user defined function Function GetHyperAddy tests if cell contains hyperlink..


HyperText = GetHyperAddy(cll)
If HyperText = "None" Then



______________________________________

try this procedure to inserts hyperlink to cells in active cell's column (starts with active cell).



Function GetHyperAddy(Cell As Range) As String
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=227
'Function purpose: To return a hyperlink address if one exists
'Assigns a value of "None" to the string if no hyperlink is present

On Error Resume Next
GetHyperAddy = Cell.Hyperlinks.Item(1).Address
If Err.Number <> 0 Then GetHyperAddy = "None"
On Error GoTo 0

End Function

Sub InsHypLnkIfNone()
'http://vbaexpress.com/forum/showthread.php?t=41274

Dim ws As Worksheet
Dim cll As Range, rng As Range
Dim LastRow As Long, acRow As Long, acCol As Long
Dim HyperText As String, strUrl As String

With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With

strUrl = "http://gisweb.claycogov.com/maps/index.html?p="

Set ws = Worksheets("Sheet1") 'sample sheet name.
'Set ws = Worksheets("Data") 'sample sheet name
'Set ws = Worksheets("Report") ' sample sheet name

With ws
acRow = ActiveCell.Row
acCol = ActiveCell.Column
LastRow = .Cells(.Rows.Count, acCol).End(xlUp).Row
Set rng = .Range(.Cells(acRow, acCol), .Cells(LastRow, acCol))
End With

On Error Resume Next
For Each cll In rng
HyperText = GetHyperAddy(cll)
If HyperText = "None" Then
cll.Hyperlinks.Add cll, strUrl & cll.Value
End If
cll.Font.Size = 10 'makes cell's font size 10
Next cll
On Error GoTo 0

With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With

End Sub