Сценарий для исправления сломанных гиперссылок в Excel

Question

У меня есть электронная таблица, которая используется для отслеживания заказов на работу. Первый столбец листа имеет номера, начинающиеся с 14-0001 и продолжающиеся последовательно вплоть до конца. Цифры были гиперссылки на .XLS их соответствующего рабочего порядка (например, ячейка, содержащая 14-0001 ссылки на Z: \ WorkOrders \ 14-0001-Имя задачи \ 14-0001-Task Name.xls)

Проблема это мой компьютер разбился, и когда Excel восстановить файл все гиперссылка изменены с

**"Z:\blah blah\WorkOrders\14-****-Task Name\14-****-Task Name.xls"** 

в

**"C:\Users\blahblah\WorkOrders\14-****-Task Name\14-****-Task Name.xls"** 

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

Heres скрипт я нашел в Интернете, который из чего я понял, что должен делать то, что я хочу, но когда я запускаю скрипт из окна VB в Excel я получаю «Ошибка компиляции: Аргумент не факультативное» и подчеркивает Sub CandCHyperlinx()

Код:

Option Explicit 
Sub CandCHyperlinx() 

Dim cel As Range 
Dim rng As Range 
Dim adr As String 
Dim delstring As String 

'string to delete: CHANGE ME! (KEEP quotes!) 
delstring = "C:\Users\***\AppData\Roaming\Microsoft\Excel\" 

'get all cells as range 
Set rng = ActiveSheet.UsedRange 

'ignore non hyperlinked cells 
On Error Resume Next 

'check every cell 
For Each cel In rng 
    'skip blank cells 
    If cel <> "" Then 
     'attempt to get hyperlink address 
     adr = cel.Hyperlinks(1).Address 
     'not blank? then correct it, is blank get next 
     If adr <> "" Then 
      'delete string from address 
      adr = Application.WorksheetFunction.Substitute(adr, delstring) 
      'put new address 
      cel.Hyperlinks(1).Address = adr 
      'reset for next pass 
      adr = "" 
     End If 
    End If 
Next cel 

End Sub 

Является ли это даже правильный сценарий? Что я делаю не так?

Answer 1

Попробуйте это:

Sub Macro1() 

    Const FIND_TXT As String = "C:\" 'etc 
    Const NEW_TXT As String = "Z:\" 'etc 

    Dim rng As Range, hl As Hyperlink 

    For Each rng In ActiveSheet.UsedRange.Cells 

     If rng.Hyperlinks.Count > 0 Then 
      Set hl = rng.Hyperlinks(1) 
      Debug.Print rng.Address(), "Before", hl.TextToDisplay, hl.Address 
      hl.TextToDisplay = Replace(hl.TextToDisplay, FIND_TXT, NEW_TXT) 
      hl.Address = Replace(hl.Address, FIND_TXT, NEW_TXT) 
      Debug.Print rng.Address(), "After", hl.TextToDisplay, hl.Address 
     End If 

    Next rng 


End Sub 

Answer 2

Я только что была такая же проблема, и все макросы я пытался не работал для меня. Этот вариант адаптирован из Тима выше и из этой нити Office Techcentre thread. В моем случае все мои гиперссылки были в столбце B, между строками 3 и 400 и «скрыты» за именем файла, и я хотел вернуть ссылки в папку Dropbox, где они принадлежат.

Sub FixLinks3() 

Dim intStart As Integer 

Dim intEnd As Integer 

Dim strCol As String 

Dim hLink As Hyperlink 

intStart = 2 

intEnd = 400 

strCol = "B" 


For i = intStart To intEnd 

    For Each hLink In ActiveSheet.Hyperlinks 
    hLink.TextToDisplay = Replace (hLink.TextToDisplay, "AppData/Roaming/Microsoft/Excel", 
    "Dropbox/References") 
    hLink.Address = Replace(hLink.Address, "AppData/Roaming/Microsoft/Excel", 
    "Dropbox/References") 
    Next hLink 

    Next i 

End Sub 

Благодарим за помощь, Тим!