Sub CheckUpHyperlinks(target As Range)
'Проверка гиперссылок в заданном диапазоне
'ставит ОК справа от рабочих ссылок
Dim one As Range
        On Error Resume Next    
        For Each one In target.Cells
            one.Hyperlinks(1).Follow
            If Err.Number = 0 Then one.Cells(1, 2) = "OK"
        Next one
        On Error GoTo 0
End Sub

Private Function GetURLstatus(ByVal URL$) As Long
    ' функция проверяет наличие доступа к ресурсу URL$ (файлу или каталогу)
    ' возвращает код ответа сервера (число), либо 0, если ссылка ошибочная
    ' (200 - ресурес доступен, 404 - не найден, 403 - нет доступа, и т.д.)
    ' http://excelvba.ru/code/GetURLstatus
    On Error Resume Next: URL$ = Replace(URL$, "\", "/")
     Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
     xmlhttp.Open "GET", URL, "False"
     xmlhttp.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
     xmlhttp.send
     GetURLstatus = Val(xmlhttp.Status)
     Set xmlhttp = Nothing
End Function

Sub check()
     With Application: .ScreenUpdating = 0: .EnableEvents = 0: End With
     Dim rng As Range
     Dim cell As Range
     Set rng = Selection
     For Each cell In rng.Cells
         Select Case GetURLstatus(cell.Hyperlinks(1).Address)
             Case 200: cell.Offset(0, 1) = "OK"
             Case Else: cell.Offset(0, 1) = GetURLstatus(cell.Hyperlinks(1).Address)
         End Select
     Next
     With Application: .ScreenUpdating = 1: .EnableEvents = 1: End With
End Sub