Friday, September 16, 2011

Create Hyperlink for filenames or folder names from the cells in excel

This macro is to create hyperlinks to a list of file names in the excel to a specific folder containing the list of files

For example I have a folder containing thousands of subfolders and I have the list of sub folders present in that folder.
I have to specific folders and open it for which i would generally use to search the "Main folder" for the "Sub folder" and open it each time since the folder has thousands of sub folder the search takes a lot of time.
Here is a easy way to solve my problem.
I create a hyper link in excel to only the specific sub folders which i have to check and open them by clicking the hyperlink.


Note: Please take care that the the list of folder names you want to create hyperlink is present in "Sheet1" and in Column "A" or else you can modify the code according to your need.
Provide the Main folder path in the Input Box when it pop ups.

For any assistance please post me.

Here is the code for hyperlinking.

****************************************************************

Code:

Sub Create_Hyperlink()

Dim Path As String
Dim lastRow As Long
Dim rOffset As Long
Dim partialPath As String
Dim linkPath As String

Path = InputBox("Please paste the path to which the list should be hyperlinked")
 
  Const SheetToPutLinksOn = "Sheet1"
  Const ColumnWithFileNames = "A"
  Const firstFilenameRow = 1

  ThisWorkbook.Worksheets(SheetToPutLinksOn).Activate
  Application.ScreenUpdating = True
  partialPath = Path & "\"
  lastRow = Range(ColumnWithFileNames & Rows.Count).End(xlUp).Row - _
   firstFilenameRow
  Range(ColumnWithFileNames & firstFilenameRow).Select
  Application.ScreenUpdating = True
  For rOffset = 0 To lastRow
     If Not IsEmpty(ActiveCell.Offset(rOffset, 0)) Then
      linkPath = partialPath & ActiveCell.Offset(rOffset, 0).Text
      ActiveSheet.Hyperlinks.Add anchor:=ActiveCell.Offset(rOffset, 0), _
       Address:=linkPath
    End If
  Next
  ThisWorkbook.Saved = True
  Application.ScreenUpdating = True

End Sub

****************************************************************

No comments:

Post a Comment