Подсветка работающих гиперссылок

[AChrist]

Спасибо за ответ.
Я вот не понимаю, что делает этот код:

FileFolderExists = Dir(HL) = ""

На все случаи возвращает 0.

Вот вложил файл. Рисунок держим на C:\, а текстовый на D:\

[EducatedFool]

Вот так будет работать:



В коде было 3 ошибки. Теперь всё правильно:

Public Function FileFolderExists(ByRef cell As Range) As Boolean
    On Error Resume Next
    thisworkbookpath = Replace(cell.Parent.Parent.FullName, cell.Parent.Parent.Name, "")
    hl = cell.Hyperlinks(1).Address
    If Dir(hl) = "" And hl <> "" Then hl = thisworkbookpath & Replace(hl, "/", "\")
    FileFolderExists = Dir(hl) <> "" And hl <> ""
End Function

Public Sub TestFileExistence()
    rr = 15    '  ставим в какой столбец записывать результат
    Dim cell As Range
    For Each cell In Range([A1], Range("A" & Rows.Count).End(xlUp)).Cells
        cell(1, rr) = -1 * FileFolderExists(cell)
    Next cell
End Sub

[AChrist]

В коде было 3 ошибки.

Только одна в

FileFolderExists = Dir(hl) <> "" And hl <> ""

:-)
Идеально работает. Спасибо за помощь и понятные объяснения.

[denis524]

В данном макросе в ячейках с текстом, где нет гиперссылки макрос ставит 1 (Истина). Как исправить?

[Анатолий8383]

Здравствуйте, наткнулся на ваш макрос,

Public Function FileFolderExists(ByRef cell As Range) As Boolean
On Error Resume Next
thisworkbookpath = Replace(cell.Parent.Parent.FullName , cell.Parent.Parent.Name, "")
hl = cell.Hyperlinks(1).Address
If Dir(hl) = "" And hl <> "" Then hl = thisworkbookpath & Replace(hl, "/", "\")
FileFolderExists = Dir(hl) <> "" And hl <> ""
End Function

Public Sub TestFileExistence()
rr = 15 ' ставим в какой столбец записывать результат
Dim cell As Range
For Each cell In Range([A1], Range("A" & Rows.Count).End(xlUp)).Cells
cell(1, rr) = -1 * FileFolderExists(cell)
Next cell
End Sub

попробовал, все работает отлично НО только до 145 строки, подскажите почему от до конца таблицы не работает? В таблице около 3000 строк