PDA

View Full Version : Solved: Create hyperlink and activate it



MichaelATO
03-17-2007, 01:07 PM
Hi all;
I have been given the task of shrinking a worksheet in size. part of the problem is that two columns in the sheet contain "active" hyperlinks to an intranet personnel directory. these I am going to remove and replace their values with a VBA module that will create the hyperlink by appending a userid at the end to make the connection to the intrante personnel directory.
I would like to have the code do the follwing:
Use double click event on name of individual in sheet 1.
Find individual (column 1) on sheet two and using offset function, go to column 2 to locate the userid on found record.
Concatenate the URL, which is part of the vba, of the directory listing to the userid. This would look then like http://xxxxetc=UserId.
Activate the hyperlink created and jump to the directory listing.
Sheet 2 should be hidden as the userid should not be visible.
Would anyone be able to assist in this please? Thanks. the code thus far is (note file attached):

The code of course still does not work. Can anyone please assist? thanks
Option Explicit


Private Sub Worksheet_BeforeDoubleClick(ByVal _
Target As Range, Cancel As Boolean)
Dim Link As String
Dim cell As Range
Dim svalue As String 'string to look for is svalue and is filled with a value
'when you doubleclicked your worksheet
Dim lrow As Long 'last row of data
Dim UserId As String 'Userid is offset to euivalent svalue in "Directory" worksheet

svalue = Worksheets("LAC List").ActiveCell.Value
lrow = Worksheets("Directory").Range("A" & Rows.Count).End(xlUp).Row
UserId = Worksheets("Directory").Offset(0, 1).Value
Link = "http://cbr07sap200:1083/UserInfo.asp?userid=" & UserId

If (Target.Column <> 6 And Target.Column <> 7) Then Exit Sub
If Target.Row = 1 Then Exit Sub
On Error Resume Next
Cancel = True 'Get out of edit mode

Worksheets("Directory").Activate
For Each cell In Worksheets("Directory").Range("A2:A" & lrow)
'look for matching values
If cell Like "*" & svalue & "*" Then
cell.Offset(0, 1).Value
If Worksheets(Target.Value) Is Nothing Then
MsgBox Target.Value & " -- Not Listed. Please check the Directory"
End If



End Sub

MichaelATO
03-19-2007, 03:08 AM
Seeing as no one was able to assist at this stage I came up with the folowing script which I applied in the real case scenario at work.
The script works though it does so on the same sheet as I have not been able ot work out how to find the double clicked name record on the 2nd sheet and work the hyperlink from there.

Note the spreadshhehet has 9 columns by 28000 rows of data. By leaving the name of the officer and the full hyperlink address visible the size of the spreadsheet was 6.5mb, which is way above the 5mb limit (or below preferably) that I needed to achieve. Removing the hyperlink columns and replacing the data with the userid information reduced the size to 4.9mb. Good but not good enough as I will be adding more data in the near future. My new script is therefore:

Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Ensure only certain columns (both staff name) can be double clicked
If (Target.Column <> 7 And Target.Column <>) Then Exit Sub
If Target.Row = 1 Then Exit Sub
On Error Resume Next
Cancel = true 'Get out of edit mode
dim hlink1 As String
dim hlink2 As String
'Note columns 6 & 8 are hidden from view as these are the userids. Can be done programatically
hlink1 = "http:// and the rest of the address" & Cells(Target.Row, 6).Text
hlink2 = "http:// and the rest of the address" & Cells(Target.Row, 8).Text

If Target.Column = 7 Then
ActiveWorkbook.FollowHyperlink Address:=hlink1, NewWindow:=True
End If
If Target.Column = 9 Then
ActiveWorkbook.FollowHyperlink Address:=hlink1, NewWindow:=True
End If

End Sub

If anyone can assist further by showing me how to find the double clicked value from sheet 1, witin sheet 2 and then select the userid in sheet two to make the hyperlink connection I would appreciate it greatly. thanks.
Regards
MichaelATO

OBP
03-19-2007, 05:26 AM
Michael, if you haven't already got it working this will access Sheet 2 for you.

MichaelATO
03-21-2007, 04:57 AM
Hi All;
Seeing as I am the only one working on my problem I have finally been able to work out the total solution. I have reduced the size of th espreadsheet by a further 1 mb, as I have now also removed the userid columns. The userid's are held witin a hidden sheet called staff. The hyperlinks work and opens the respective directory url. Here is the code hope that it assists someone in the future:
[vba]:
Private Sub Worksheet_BeforeDoubleClick(ByVal _
Target As Range, Cancel As Boolean)
'Code to get the Intranet Directory details for staff members clients.
'Code developed by MichaelATO: 21-03-2007

' this locks the details to only columns F & G and starting from row 5
If (Target.Column <> 6 And Target.Column <> 7) Then Exit Sub
If Target.Row < 5 Then Exit Sub
On Error Resume Next
Cancel = True 'Get out of edit mode.
' set all necessary variables
Dim svalue1 As String
Dim hlink1 As String
Dim userid1 As String
Dim cell As Range
Dim rng1 As Range
Dim rngarea As Range

' ensure the staff name details are selected on double click
svalue1 = ActiveCell.Value

If (Target.Column = 6 Or Target.Column = 7) Then
If svalue1 <> "" Then ActiveCell.Copy ' copies the staff membername
'ensures the userdoes not see the next step where the staff members userid becomes visible
Application.ScreenUpdating = False
Worksheets("Staff").Visible = True 'unhide the staff member sheet
Worksheets("Staff").Activate ' make staff member sheet theactive sheet
End If
' enable the Autofilter and find the svalue1, which is the staff member name
Worksheets("Staff").Range("A1").AutoFilter Field:=1, Criteria1:=svalue1
With Worksheets("Staff")
'set the range for the Autofilter so that only the necessary rows are visible
Set rng1 = .AutoFilter.Range.Offset(0, 0)
.Resize (AutoFilter.Range.Row)
.SpecialCells (xlCellTypeVisible)
End With
'set the 2nd range to get the userid row and to make the userid the active cell
For Each rngarea In rng1.Rows
If rngarea.EntireRow.Hidden = False Then
userid1 = rngarea.Cells(2).Value
rngarea.Cells(2).Select
End If
Next rngarea
' Concatenate the userid to the Directory hyperlink and open the directory location.
If userid1 <> "" Then
hlink1 = "http://xxx and rest of URL" & userid1
ActiveWorkbook.FollowHyperlink Address:=hlink1, NewWindow:=True
End If
' ensure the staff details sheet is hidden again
Worksheets("Staff").Visible = xlVeryHidden
' enable normal spreadsheet operations.
Application.ScreenUpdating = True

End Sub
[vba]

MichaelATO
03-21-2007, 05:13 AM
Thanks OBP;
and I thought that no one cared......
As I had not seen your suggestion and of course not having internet access at work I put my little German brain to work and came up with a working solution. Thanks for your input.
Cheers - Michael