Help with hyperlinking files in subdirectories to a list of filenames in another work

[Talat]

Hi,

I need help with this. I have asked for help in other forums but I still do not have a working solution. I am a novice, so please be generous with your suggestions.

I have a file, INVLog which has invoice numbers recorded in column A in the format of "100021", "100059" etc with corresponding files in the subdirectories of a directory INVARCHIVE. I am attaching below the INVLog file I created for testing.

The INVARCHIVE directory contains subdirectories SX5021, SS4286, SS4250 and subdirectory SX5021 contaisn files 100021.xls and 100023.xls ... and so on

The following code works for me if all teh files were in the main folder and not in various subfolders within the INVARCHIVE main directoryr.

Option Explicit

Sub Hyperlink()
Dim lastRow As Long
Dim folderPath As String
Dim cell As Range
Dim i As Long

folderPath = "C:\Users\Talât\Desktop\INVARCHIVE\"
lastRow = Cells(Rows.Count, "A").End(xlUp).Row

For i = 1 To lastRow
Range("A" & i).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=folderPath & Cells(i, 1) & ".xls"
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleNone
Selection.Font.ColorIndex = 5

Next i
MsgBox "Linking is complete."
End Sub

I need the code adapted so that it will do exactly what the above code does, EXCEPT that it looks in all the subfolders inside the Main INVARCHIVE folder to find teh relevant files to hyperlink to.

Both the INVLog files and the INVARCHIVE contents are added to continously, and are growing. So I would need to run teh code to hyperlink teh newly added files from time to time. Apart from hyperlinking the file names in teh INVLog to teh actual files in teh subdirectories, I do not want any otehr changes made to the files.

The final code will reside in teh INVLog file and be run from there.

Thanks for any help you can give me with this. :-)

Talât

[Ken Puls]

I have asked for help in other forums but I still do not have a working solution

I appreciate you being up front with this, but can you post some links to the other forums? If the question is being actively worked on, it makes sense for someone to chime into those posts, not here.

[Talat]

Thanks but I need a fresh look into it. I had two people replying on the other forums. One did not understand what exactly was needed, and the other responder built her contribution entirely on the back of the first one. That is why I changed forums, so that I can get a fresh perspective to it.

Like I said, if all the excell files were in the same directory, I have a code that works, and I don't need any help. However, the target files are in different sub directories within one main directory, and its the solution to this that I need. A fresh pair of eyes is what I need.

Thanks.

[Ken Puls]

Okay, so basically what you're saying here is that you want to:

• Provide the top level folder in the hierarchy
• Have the routine search through the folder and it's subfolders looking for the file
• Hyperlink the filename to it's file path

Is that correct?

So questions I'd want to know up front:

• How many subfolders are we looking at here... 10, 20, 30?
• Do we need to take into account nested subfolders? How many levels deep could the file be? 1, 2, ?

I'm just concerned that building a routine could be slow depending on how many passes we need to make here. If there's lots, then we may want to look at reading all files in the directory into a list first, then culling out the ones that aren't needed, rather than going back throug a loop over and over again.

I will certainly help you with this, but I'd also appreciate two things:

• Let the others know that you are having this looked at elsewhere so they don't waste their time on it.
• Post here to let me know if you get an answer before I've completed one, so that I don't waste my time.

Fair enough?

[Talat]

Hi Ken,

Yes. Fair do!

I will answer your questions one by one.

* Yes, your understanding is correct.

* At the moment there are are about 20 folders, but this can increase to about 60 or just over, but over time my guess is that it will never be more than about 80, and probably much less. Say somewhere between 60-70 at most.

* No nested folders and hence no levels. Just the 60 to 65 subfolders containing teh excel files within the INVARCHIVE directory.

I undertake to let the others know that someone is looking at it now and let you know if anyone from another forum makes a contribution. I have to say though that his is unlikely as responses have died down now.

Below, I am pasting the solution from Lisa Green, which was the last contribution.

Option Explicit
Sub subHLinkFiles()
' Assume files exist.
' Create two filename arrays.
' One array will have just the file names.
' The other will have the full path.
Dim slFullFileNames() As String
Dim slFileNames() As String
ReDim Preserve slFullFileNames(0)
ReDim Preserve slFileNames(0)
' This is a record of the Top file and the file type looked for.
slFullFileNames(0) = "C:\Users\Talât\Desktop\INVARCHIVE\"
slFileNames(0) = "XLS"
subGetFileNames _
slFullFileNames(), _
slFileNames()
Stop
' *********************************************************************
End Sub
Sub subGetFileNames( _
spFullFileNames() As String, _
spFileNames() As String)

Dim flslFile As File
Dim flslFiles As Files
Dim follFolder As Folder
Dim follSubFolder As Folder
Dim olFS As FileSystemObject
Dim slExt As String
Dim slFile As String
Dim slFileName As String
Dim slFolder As String
Dim slShortFileName As String

slFolder = spFullFileNames(0)
Set olFS = CreateObject("Scripting.FileSystemObject")
Set follFolder = olFS.GetFolder(slFolder)
Set flslFiles = follFolder.Files
slExt = UCase(spFileNames(0))
For Each flslFile In flslFiles
slFileName = flslFile.Name

'Correct EXT?
If slExt = UCase(olFS.GetExtensionName(slFileName)) Then

' Strip the EXT.
slExt = "." & slExt
slShortFileName = Replace(UCase((slFileName)), slExt, "")

' Add to Arrays.
ReDim Preserve spFullFileNames(UBound(spFullFileNames) + 1)
spFullFileNames(UBound(spFullFileNames)) = slFolder & "\" & slFileName

ReDim Preserve spFileNames(UBound(spFileNames) + 1)
spFileNames(UBound(spFileNames)) = slShortFileName

End If
Next flslFile
For Each follSubFolder In follFolder.SubFolders
spFullFileNames(0) = follSubFolder.Path
subGetFileNames spFullFileNames, spFileNames
Next follSubFolder
' *********************************************************************
End Sub

And here is the link to the post

http://www.thecodecage.com/forumz/mi...post1054991233


Thanks for agreeing to help me on this.

Talât

[Ken Puls]

Hi Talat,

You had some good people working on it over there. Simon, in particular, works really hard at trying to make things right. I'm sure if you'd mentioned the issues he would have fixed you up.

At any rate, here's the code that should do what you need. I wrote this from scratch, so it probably won't bare any resemblance to what you had. The way it works is this:

• The folder and worksheet names you'd need to tweak are at the top of the "HyperlinkFileList" routine
• That routine clears out any existing hyperlinks, as when you update you'll want to make sure all links are still valid
• It then creates a temporary sheet to hold a table of file paths to the indivdual files in the specified folder and subfolders
• The table is populated by calling the "ListFolderContent" routine. This procedure kicks off a recursive process, which essentially means it keeps calling itself and listing all files in every level of subfolder. So even if you do nest a bunch of subfolders, it will check them all.
• It then defines a name for the table so it can easily be referred to using a VLOOKUP call
• Next it cycles through all the records in Sheet1, looks up the file path and hyperlinks it if found. (If not, it just leaves the file unlinked)
• Finally it cleans up by deleting the named range and table

The code is as follows:

Option Explicit
Sub HyperlinkFileList()
'Macro purpose:  To apply hyperlinks to files found in main folder or subfolders
    Dim wsSource As Worksheet
    Dim wsWriteResultsTo As Worksheet
    Dim rngToExamine As Range
    Dim cl As Range
    Dim sHyperlinkPath As String
    Dim sStartingFolder As String
    
    'Define folder to start with
    sStartingFolder = "C:\Users\Talât\Desktop\INVARCHIVE\"
    'Define the range to Hyperlink
    Set wsSource = Worksheets("Sheet1")
    With wsSource
        Set rngToExamine = .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    End With
    'Turn off screen updates to improve speed and prevent flashing
    Application.ScreenUpdating = False
    'Clear all existing Hyperlinks
    wsSource.Cells.Hyperlinks.Delete
    'Make sure a worksheet to hold the listing exists
    On Error Resume Next
    Set wsWriteResultsTo = Worksheets("DirListing")
    If Err.Number <> 0 Then
        'Worksheet does not exist, so create it
        Set wsWriteResultsTo = Worksheets.Add
        wsWriteResultsTo.Name = "DirListing"
    Else
        'Worksheet exists, so clear contents
        wsWriteResultsTo.Cells.ClearContents
    End If
    On Error GoTo 0
    'Set up the headers on the worksheet
    With wsWriteResultsTo
        With .Range("A1")
            .Value = "File name"
            .ColumnWidth = 20
        End With
        With .Range("B1")
            .Value = "File path"
            .ColumnWidth = 50
        End With
    End With
    'Retrieve the list of files in folder below (plus any subfolder)
    Call ListFolderContent(sStartingFolder, wsWriteResultsTo)
    'Add named range for lookups
    With wsWriteResultsTo
        ActiveWorkbook.Names.Add Name:="tblFileNames", RefersToR1C1:= _
                                 .Range("A1:B" & .Range("A" & wsWriteResultsTo.Rows.Count).End(xlUp).Row)
    End With
    'Add hyperlinks
    For Each cl In rngToExamine
        'Retrieve Hyperlink File Path
        On Error Resume Next
        sHyperlinkPath = CStr(Application.WorksheetFunction.VLookup(cl.Value, Range("tblFileNames"), 2, False))
        If Err.Number <> 0 Then sHyperlinkPath = "#N/A"
        On Error GoTo 0
        'Check and make sure the file path exists
        If sHyperlinkPath = "#N/A" Then
            'No file found.  Ignore
        Else
            'File located, insert hyperlink
            'If Excel 2000 or greater, add hyperlink with file name
            'displayed.  If earlier, add hyperlink with full path displayed
            If Val(Application.Version) > 8 Then    'Using XL2000+
                wsSource.Hyperlinks.Add _
                        Anchor:=cl, _
                        Address:=sHyperlinkPath, _
                        TextToDisplay:=sHyperlinkPath
            Else    'Using XL97
                wsSource.Hyperlinks.Add _
                        Anchor:=cl, _
                        Address:=sHyperlinkPath
            End If
        End If
    Next cl
    
    'Remove the temporary worksheet and range name
    Application.DisplayAlerts = False
    wsWriteResultsTo.Delete
    Application.DisplayAlerts = True
    ActiveWorkbook.Names("tblFileNames").Delete
End Sub
Sub ListFolderContent(sDirectory As String, wsTarget As Worksheet)
'Macro purpose:  To create a list of all files in a directory
    Dim fso As Object
    Dim File As Object
    Dim Folder As Object
    Dim SubFolder As Object
    Dim rngTarget As Range
    'Turn off screen flashing
    Application.ScreenUpdating = False
    'Create objects to get a listing of all files in the directory
    Set fso = CreateObject("Scripting.FileSystemObject")
    'Get list of files to list
    Set Folder = fso.GetFolder(sDirectory)
    'Adds each file to the list
    For Each File In Folder.Files
        If InStr(1, LCase(File.Path), ".xls") Then
            With wsTarget.Range("A" & wsTarget.Rows.Count).End(xlUp).Offset(1, 0)
                .Value = CStr(Left(File.Name, InStr(1, LCase(File.Name), ".xls") - 1))
                .Offset(0, 1).Value = File.Path
            End With
        End If
    Next
    'Check each subfolder for files that should be added
    For Each SubFolder In Folder.SubFolders
        Call ListFolderContent(SubFolder.Path, wsTarget)
    Next SubFolder
End Sub

I've also attached a workbook with the code embedded. It is in Module2.

If I've missed anything, let me know and we'll get it tweaked. I think this should do it for you though.

[Talat]

Hi Ken,

Many thanks. I have tested this now on the live data and all is well. It does exactly what I need it to do. I am really grateful to you for taking this on and doing it so quickly as well. Simon and Lisa were also good to me and I have thanked them. I have learnt new things about VBA coding from Lisa which I had no notion of previously, so it has been a good useful experience for me even though my origional brief was not understood correctly.

Thank you very much , again.

Talât

[Ken Puls]

No problem Talât, I'm glad it worked.

Just for reference (ha!), I know Lisa had you set a reference to the Microsoft Scripting Runtime library. This was necessary as she was using Early Binding to the FSO model to accomplish her approach. I've used a Late Binding approach, as this makes the code a bit more portable across systems with different versions. Net effect is that you can uncheck that reference in VBE->Tools->References as Late Binding doesn't require it.

CHeers,