0

I ahve an Excel work book containing a large number of sheets. Each sheet has between 1 and 12 Hyperlinks to different documents on a website. These dicuments are updated from time to time. I would like a macro that lists all the Hyperlinks in a new sheet but also lists the sheet name next to each link. I have the following that lists the Hyperlinks and the cell ref

Sub CopyHyperLinks()  
  Dim rCell As Range 
  Dim ws As Worksheet 
  Dim Lhyper As Long                  
  On Error Resume Next 
  Application.DisplayAlerts = False 
  Sheets("Hypers").Delete 
  On Error Goto 0 
  Application.DisplayAlerts = True 
  Sheets.Add().Name = "Hypers" 

  For Each ws In Worksheets
    If ws.Name <> "Hypers" Then 
      For Lhyper = 1 To ws.UsedRange.Hyperlinks.Count  
        ws.Hyperlinks(Lhyper).Range.Copy 
        With Sheets("Hypers").Cells(Rows.Count, 1).End(x1Up)  
          .Offset(1, 0).PasteSpecial
          .Offset(1, 1) = ws.Hyperlinks(Lhyper).Range.Address 
        End
        Application.CutCopyMode = False 
       Next Lhyper 
     End If 
  Next ws 
End Sub

How can i modify this to show the sheet name instead of the cell ref. is it also possible to then check that these Hyperlinks are valid destinations?

4

1 回答 1

4

You can get the name of the worksheet of the hyperlink with this line:

ws.Hyperlinks(Lhyper)..Range.Worksheet.Name

Here's is your reworked code (it contained some other syntactical errors that I corrected):

Sub CopyHyperLinks()
    Dim rCell As Range
    Dim ws As Worksheet
    Dim Lhyper As Long
    Dim rngLink As Range

    Application.DisplayAlerts = False

    On Error Resume Next
    Sheets("Hypers").Delete

    On Error GoTo 0
    Application.DisplayAlerts = True

    Sheets.Add().Name = "Hypers"

    For Each ws In Worksheets
        If ws.Name <> "Hypers" Then
            For Lhyper = 1 To ws.UsedRange.Hyperlinks.Count
                Set rngLink = ws.Hyperlinks(Lhyper).Range
                rngLink.Copy
                With Sheets("Hypers").Cells(Rows.Count, 1).End(xlUp)
                    .Offset(1, 0).PasteSpecial
                    .Offset(1, 1) = rngLink.Address
                    .Offset(1, 2) = rngLink.Worksheet.Name
                    .Offset(1, 3) = CheckHyperlink(ws.Hyperlinks(Lhyper).Address)
                End With
                Application.CutCopyMode = False
            Next Lhyper
        End If
    Next ws
End Sub

If you want to verify the links, include the code from this answer. Include this line in your code:

.Offset(1, 3) = CheckHyperlink(ws.Hyperlinks(Lhyper).Address)

and also this routine:

Public Function CheckHyperlink(ByVal strUrl As String) As Boolean

    Dim oHttp As New MSXML2.XMLHTTP30

    On Error GoTo ErrorHandler
    oHttp.Open "HEAD", strUrl, False
    oHttp.send

    If Not oHttp.Status = 200 Then CheckHyperlink = False Else CheckHyperlink = True

    Exit Function

ErrorHandler:
    CheckHyperlink = False
End Function

You need to include a reference to the "Microsoft XML" library in your VBA project.

于 2013-02-21T11:04:57.950 回答