1,105,334 Community Members

Add Path and Filename Hyperlink

Member Avatar
AndreRet
Industrious Poster
4,492 posts since Jan 2008
Reputation Points: 362 [?]
Q&As Helped to Solve: 499 [?]
Skill Endorsements: 24 [?]
 
0
 

You would use something similar to -

MyCell = ActiveCell.Address
Member Avatar
tinstaafl
Postaholic
2,012 posts since Jun 2010
Reputation Points: 559 [?]
Q&As Helped to Solve: 402 [?]
Skill Endorsements: 35 [?]
 
0
 
MyCell = ActiveCell.Address

When I was coding this it looked like, after the code left the change event handler, activecell became the cell with focus, not the cell that just changed. So I used a global to catch that cell from Target. there are probably other ways to do it though. I was mainly going functionality at this point.

so how do I get it to count to the row and cell that I'm typing in?

the code is fired from the change event. changing text in another cell in the same column should fire it again. If you want all the hyperlinks together and not overwriting, then change Counter = 1, to

If counter <1 then
    counter =1
End If

If you want cells from different columns to fire it, change the column conditional in the change event code, to check for an acceptable column to accept changes from. Kepp some sort of conditional in there, otherwise adding the hyperlinks will fire it as well

Member Avatar
Divinedar
Light Poster
43 posts since Oct 2009
Reputation Points: 12 [?]
Q&As Helped to Solve: 0 [?]
Skill Endorsements: 0 [?]
 
0
 

OK I understand that but where would it fit in the code. Not sure I understand that part.

Since I'm looking for the cell I assume it goes here:

Sub AddHyperlinks(ByVal f2 As Folder)
    For Each fil In f2.Files
    'If the string matches add the hyperlink
    If InStr(1, fil.Name, TargetCell.Text) > 0 Then
       Worksheets(1).Hyperlinks.Add Anchor:=Hyprlinks.Cells(Counter), Address:=fil.Path
       'Increment to the next cell
       Counter = Counter + 1
    End If
    Next
End Sub

I know it works with this
InStr(1, fil.Name, TargetCell.Text)
cause this is where I'm having the problem with the 1.

Member Avatar
tinstaafl
Postaholic
2,012 posts since Jun 2010
Reputation Points: 559 [?]
Q&As Helped to Solve: 402 [?]
Skill Endorsements: 35 [?]
 
0
 

In this subroutine is where everthing gets started. you can change the If Target.Column = 1 Then statement to reflect which columns you want to accept the search string from(i.e. If Target.Column = 1 Or Target.Column = 2 Or Target.Column = 3 Then)

    'This starts the search routine
    Private Sub Worksheet_Change(ByVal Target As Range)
        'Change this to the column where the input is coming from
        If Target.Column = 1 Then
            Set TargetCell = Target
            MakeHyperlinks
        End If
    End Sub

cause this is where I'm having the problem with the 1.

The '1' in the parameters, is the index to start searching from. The value InStr returns is either the index where the search string is found, or -1 if it isn't found.

Member Avatar
Divinedar
Light Poster
43 posts since Oct 2009
Reputation Points: 12 [?]
Q&As Helped to Solve: 0 [?]
Skill Endorsements: 0 [?]
 
0
 

Okay I'm still working on this and can't seem to get it to work properly. It's not that it's not working, it's slow and I need to search and replace some hyperlinks because when you close the workbook, you loose the links.

This is what I have that works but it's slow because there are subfolders and plenty files:

Private Sub Worksheet_Change(ByVal Target As Range)
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

If Target.Column = 7 Then
MakeHyperLink Target, "Q:\"
End If

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

End Sub

Option Explicit
Private Files As Dictionary
Private StrFile As String
Dim StrFlePath As String, FleCollection, fle, f1
Public Function MakeHyperLink(InRange As Range, _
ToFolder As String, _
Optional InSheet As Worksheet, _
Optional WithExt As String = "doc") As String
Dim Rng As Range
Dim Filename As String
Dim Ext As String

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

GetFileAddress
'check to see if folder has trailing \
If Right(ToFolder, 1) <> "\" Then
Filename = ToFolder & "\"
Else
Filename = ToFolder
End If
'check to see if need ext
If WithExt <> "" Then
'check to see if ext has leading dot
If Left(WithExt, 1) <> "." Then
WithExt = "." & WithExt
End If

End If
'if not explicit sheet then assign active
If InSheet Is Nothing Then
Set InSheet = ActiveSheet
End If
'now for every cell in range
For Each Rng In InRange
'does range have value
If Rng <> "" Then
'make hyperlink to file
StrFlePath = Files(UCase(Rng.Text & WithExt))

InSheet.Hyperlinks.Add Anchor:=Rng, Address:= _
StrFlePath, TextToDisplay:=Rng.Text

End If
Next

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

End Function
Sub GetFileAddress()

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

Set Files = New Dictionary
FindFolder "Q:\"

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

End Sub

Public Function FindFolder(strPath As String) As String
Dim fs, f2, subfld

Set fs = CreateObject("scripting.filesystemobject")

Set f1 = fs.GetFolder(strPath)
Set f2 = f1.SubFolders
Set FleCollection = f1.Files

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .StatusBar = LoopNum
    End With


For Each fle In FleCollection
If Not (Files.Exists(UCase(fle.Name))) Then
Files.Add UCase(fle.Name), fle.Path
End If
Next

For Each subfld In f2
FindFolder subfld.Path
Next

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

End Function

Also I need to replace some hyperlinks that already exist. What happen is when you close the workbook the links stop working and looses the beginning of the hyperlink.

This is the code that I have for that:

Sub FindReplaceHLinks(sFind As String, sReplace As String, _
    Optional lStart As Long = 1, Optional lCount As Long = -1)

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .StatusBar = LoopNum
    End With

    Dim rCell As Range
    Dim hl As Hyperlink

    For Each rCell In ActiveSheet.UsedRange.Cells
        If rCell.Hyperlinks.Count > 0 Then
            For Each hl In rCell.Hyperlinks
                hl.Address = Replace(hl.Address, sFind, sReplace, lStart, lCount, vbTextCompare)
            Next hl
        End If
    Next rCell

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

End Sub

Sub ReplacePartHyperlinkAddress()
    Dim hLink As Hyperlink
    Dim wSheet As Worksheet

    For Each wSheet In Worksheets
        For Each hLink In wSheet.Hyperlinks
            hLink.Address = Replace(hLink.Address, "..\..\..\..\QA\", "Q:\")
        Next hLink
    Next wSheet
End Sub

I would like to condense this as much as possible and see if that helps it work faster. The replacement code for the hyperlinks works but don't get all the hyperlinks on the worksheet. Would be nice if the the hyperlink replacement code could check each worksheet when it opens or by the click of a button that it would check all hyperlinks within the workbook.

Any ideas anybody.

Member Avatar
tinstaafl
Postaholic
2,012 posts since Jun 2010
Reputation Points: 559 [?]
Q&As Helped to Solve: 402 [?]
Skill Endorsements: 35 [?]
 
0
 

This is what I have that works but it's slow because there are subfolders and plenty files:

One thing that might make it faster is take out all the sheet update except the one in the Worksheet_Change routine.

You
This article has been dead for over three months: Start a new discussion instead
Post:
Start New Discussion
Tags Related to this Article