Страницы: 1
RSS
Макрос выбора пути к файлу для формулы ГИПЕРССЫЛКА
 
Добрый день, уважаемые форумчане! Требуется ваша помощь.

Есть реестр учета контрактов объемом более 1000 строк. Для удобства сделаны гиперссылки к самим договорам.
Договора находятся в сетевой папке. Адрес к ним получается типа: \\192.168.1.200\Обмен\Договор.xlsx
Ссылки делаются через контекстное меню: ПКМ - Гиперссылка - выбор пути к файлу
При случайном перемещении реестра и возврате обратно ломаются гиперссылки к файлу. Так как пользуются данной таблицей несколько сотрудников, я устал уже чинить гиперссылки и никто не признается кто сломал.

До сего момента я чинил ссылки найденным здесь макросом:
Код
Sub ЗаменаИспорченныхГиперссылок()
    On Error Resume Next
    Dim hl As Hyperlink, oldString As String, newString As String, sh As Worksheet
    ' часть гиперссылки, подлежащая замене
    oldString = "\\192.168.0.200\Users\User\AppData\Roaming\Microsoft"
    ' на что заменяем
    newString = "\\192.168.0.200\обмен"
    For Each sh In ActiveWorkbook.Worksheets    ' перебираем все листы в активной книге
        For Each hl In sh.Hyperlinks    ' перебираем все гиперссылки на листе
            If hl.Address Like oldString & "*" Then
                hl.Address = Replace(hl.Address, oldString, newString)
            End If
        Next
    Next sh
End Sub

Сейчас данный код почему-то перестал работать. Кстати, почему? Ошибку не найду.

Появилась мысль переделать все гиперссылки из контекстного меню в функцию ГИПЕРССЫЛКА, чтобы можно было в случае чего менять пути путем автозамены части текста в формуле.
Но в эту формулу путь к файлу необходимо будет прописывать вручную, что проблематично для некоторых пользователей.
Как бы реализовать кнопку выбора файла в проводнике для функции ГИПЕРССЫЛКА?
Во вложении пример файла.
 
Цитата
Александр Иванов написал: Ошибку не найду.
Удалите из кода On Error Resume Next и найдете ошибку. По крайней мере строку с ошибкой
Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sanja написал:
Удалите из кода On Error Resume Next и найдете ошибку. По крайней мере строку с ошибкой
Удаляю, запускаю - ничего не происходит. Ссылки не заменяются, ошибок не выдается.
 
Ну значит ни один адрес гиперссылки у вас НЕ Like oldString & "*"
Код
oldString = "\\192.168.0.200\Users\User\AppData\Roaming\Microsoft"

В первой строке вообще нет hl.Address
Во второй
Код
hl.Address = "..\Content.Outlook\Обмен\Обмен\!!! КОНТРАКТЫ !!!\2016 год\ЗМО\Технологии успеха ООО (060116 от 31.12.2015) сопровождение программного продукта УАИС Бухгалтерия.pdf"
В третьей
Код
hl.Address = ..\Content.Outlook\Обмен\Обмен\!!! КОНТРАКТЫ !!!\2016 год\ЗМО\Мослифт ОАО (030116 от 31.12.2015) обслуживание запирающих устройств.pdf

Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sanja написал:
Ну значит ни один адрес гиперссылки у вас НЕ Like oldString & "*"
До сего момента ссылки чинились. Сейчас файл отправлялся по почте потом вернули на место.
Я не силен в VBA, только начинаю разбираться.

Но всё же думаю более правильно все ссылки переделать на ГИПЕРССЫЛКА.
Но добавление новых позиций введет всех пользователей в затруднение, так как нет возможности выбрать в проводнике нужный контракт, чтобы сделать на него гиперссылку. Как бы вот это реализовать?
Страницы: 1
Наверх