CODEWITHSUNDEEP
excelvbahyperlinkfilenames
vancouver3
vancouver3

Reputation: 49

Add external hyperlink to Excel activesheet

I would like to add a hyperlink(of its file path - sName+sPath) to each cell in row "A" on my activesheet, I couldn't find a way to do it without overhaul the whole thing.

It would be great if you can help out.

Many thanks.

Here is what I got:

  Sub PendingReviewers()
  Dim sPath As String, sName As String
  Dim bk As Workbook, sh As Worksheet
  Dim rw As Long

  Set sh = ActiveSheet  '

  sh.Cells.ClearContents

         cRow = 1
         sh.Cells(cRow, 1) = "Document Name"
         sh.Cells(cRow, 2) = "Reviewer"
         sh.Cells(cRow, 3) = "Decision" 'H5

     rw = 2 '  row to write
     sPath = "P:\ISO 9001 Documents\Review Documents\" ' Dir for file location
     sName = Dir(sPath & "*QDRS.xlsx") ' for xl2010 & "*.xlsx"
     Do While sName <> "" 'Loop until filename is blank
     Set bk = Workbooks.Open(sPath & sName)

     sh.Cells(rw, "A") = bk.Name
     sh.Cells(rw, "B") = bk.Worksheets(2).Range("B39")
     sh.Cells(rw, "C") = bk.Worksheets(2).Range("H39")
     sh.Cells(rw, "D") = bk.Worksheets(2).Range("K39")
     sh.Cells(rw, "E") = bk.Worksheets(2).Range("B48")
     sh.Cells(rw, "F") = bk.Worksheets(2).Range("I48")
     sh.Cells(rw, "G") = bk.Worksheets(2).Range("G4")
     sh.Cells(rw, "H") = bk.Worksheets(2).Range("B32")
     sh.Cells(rw, "I") = bk.Worksheets(2).Range("D39")
       rw = rw + 1
     sh.Cells(rw, "A") = bk.Name
     sh.Cells(rw, "B") = bk.Worksheets(2).Range("B40")
     sh.Cells(rw, "C") = bk.Worksheets(2).Range("H40")
     sh.Cells(rw, "D") = bk.Worksheets(2).Range("K40")
     sh.Cells(rw, "I") = bk.Worksheets(2).Range("D40")
       rw = rw + 1
     sh.Cells(rw, "A") = bk.Name
     sh.Cells(rw, "B") = bk.Worksheets(2).Range("B41")
     sh.Cells(rw, "C") = bk.Worksheets(2).Range("H41")
     sh.Cells(rw, "D") = bk.Worksheets(2).Range("K41")
     sh.Cells(rw, "I") = bk.Worksheets(2).Range("D41")
        rw = rw + 1
     sh.Cells(rw, "A") = bk.Name
     sh.Cells(rw, "B") = bk.Worksheets(2).Range("B42")
     sh.Cells(rw, "C") = bk.Worksheets(2).Range("H42")
     sh.Cells(rw, "D") = bk.Worksheets(2).Range("K42")
     sh.Cells(rw, "I") = bk.Worksheets(2).Range("D42")
        rw = rw + 1
     sh.Cells(rw, "A") = bk.Name
     sh.Cells(rw, "B") = bk.Worksheets(2).Range("B43")
     sh.Cells(rw, "C") = bk.Worksheets(2).Range("H43")
     sh.Cells(rw, "D") = bk.Worksheets(2).Range("K43")
     sh.Cells(rw, "I") = bk.Worksheets(2).Range("D43")
        rw = rw + 1
     sh.Cells(rw, "A") = bk.Name
     sh.Cells(rw, "B") = bk.Worksheets(2).Range("B44")
     sh.Cells(rw, "C") = bk.Worksheets(2).Range("H44")
     sh.Cells(rw, "D") = bk.Worksheets(2).Range("K44")
     sh.Cells(rw, "I") = bk.Worksheets(2).Range("D44")


       rw = rw + 1

      bk.Close SaveChanges:=False
     sName = Dir()
     Loop

     End Sub

Upvotes: 0

Views: 60

Answers (1)

findwindow
findwindow

Reputation: 3153

Is this what you want?

Add something like link = sPath & sName right before the loop then

replace sh.Cells(rw, "A") = bk.Name

with sh.Hyperlinks.Add Anchor:=sh.Cells(rw, 1), Address:=link

Upvotes: 2

Related Questions