Сортировать мертвые гиперссылки в Excel с VBA?

Question

Название гласит:

У меня есть лист Excel с колонкой, полной гиперссылок. Теперь я хочу, чтобы скрипт VBA проверял, какие гиперссылки устарели или работают, и делает запись в следующие столбцы с текстом 404 Ошибка или активным.

Надеюсь, кто-нибудь сможет мне помочь, потому что я не очень хорош в VB.

EDIT:

Я нашел @ http://www.utteraccess.com/forums/printthread.php?Cat=&Board=84&main=1037294&type=thread

Решение, которое сделано для слова, но проблема в том, что мне нужно это решение для Excel. Может кто-нибудь перевести это в решение Excel?

Private Sub testHyperlinks()
    Dim thisHyperlink As Hyperlink
    For Each thisHyperlink In ActiveDocument.Hyperlinks
        If thisHyperlink.Address <> "" And Left(thisHyperlink.Address, 6) <> "mailto" Then
            If Not IsURLGood(thisHyperlink.Address) Then
                Debug.Print thisHyperlink.Address
            End If
        End If
    Next
End Sub


Private Function IsURLGood(url As String) As Boolean
    ' Test the URL to see if it is good
    Dim request As New WinHttpRequest

    On Error GoTo IsURLGoodError
    request.Open "GET", url
    request.Send
    If request.Status = 200 Then
        IsURLGood = True
    Else
        IsURLGood = False
    End If
    Exit Function
IsURLGoodError:
        IsURLGood = False
End Function

Answer 1

Сначала добавьте ссылку на Microsoft XML V3 (или выше), используя Сервис-> Ссылки. Затем вставьте этот код:

Option Explicit

Sub CheckHyperlinks()

    Dim oColumn As Range
    Set oColumn = GetColumn() ' replace this with code to get the relevant column

    Dim oCell As Range
    For Each oCell In oColumn.Cells

        If oCell.Hyperlinks.Count > 0 Then

            Dim oHyperlink As Hyperlink
            Set oHyperlink = oCell.Hyperlinks(1) ' I assume only 1 hyperlink per cell

            Dim strResult As String
            strResult = GetResult(oHyperlink.Address)

            oCell.Offset(0, 1).Value = strResult

        End If

    Next oCell


End Sub

Private Function GetResult(ByVal strUrl As String) As String

    On Error Goto ErrorHandler

    Dim oHttp As New MSXML2.XMLHTTP30

    oHttp.Open "HEAD", strUrl, False
    oHttp.send

    GetResult = oHttp.Status & " " & oHttp.statusText

    Exit Function

ErrorHandler:
    GetResult = "Error: " & Err.Description

End Function

Private Function GetColumn() As Range
    Set GetColumn = ActiveWorkbook.Worksheets(1).Range("A:A")
End Function

Answer 2

Код Гэри идеален, но я бы предпочел использовать публичную функцию в модуле и использовать ее в ячейке как функцию. Преимущество состоит в том, что вы можете использовать его в ячейке по вашему выбору или в любой другой более сложной функции.

В приведенном ниже коде я изменил код Гэри, чтобы он возвращал логическое значение, и затем вы можете использовать этот вывод в = IF (CHECKHYPERLINK (A1); "OK"; "FAILED"). В качестве альтернативы вы можете вернуть целое число и вернуть сам статус (например: = IF (CHECKHYPERLINK (A1) = 200; "OK"; "FAILED"))

А1: http://www.whatever.com
A2: = IF (CHECKHYPERLINK (A1); «OK»; «FAILED»)

Чтобы использовать этот код, пожалуйста, следуйте инструкциям Гэри и дополнительно добавьте модуль в рабочую книгу (щелкните правой кнопкой мыши на VBAProject -> Insert -> Module) и вставьте код в модуль.

Option Explicit

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

Также имейте в виду, что, если страница не работает, время ожидания может быть большим.