hyperlink corrotto

[giostacchio]

buongiorno ho un problemino.
ho fatto un recupero da server e mi si sono corrotto tutti gli hyperlink
si può modificare solo la parte iniziale di un hyper ?
ovvero il mio link attuale è
File:///\\XenFs02\Gruppi\@GMT-2017.04.14-09.00.15\Qualità\.......( più altre informazioni )

e dovrebbe però diventare:
File:///\\XenFs02\Gruppi\Qualità\.......( più altre informazioni )

vi giro esempio del file
https://wetransfer.com/downloads/739c70 ... 401/4022c3

ho provato anche la seguente macro ma non funziona, collegandol direttamente nel foglio1 , ma ho provato anche con un pulsante

Codice: Seleziona tutto

Sub Pulsante1822_Click()

     Dim mySheet As Worksheet
     Dim myLink As Hyperlink
     Dim oldPath As String, newPath As String
     oldPath = "\\XenFs02\gruppi\@GMT-2017.04.14-09.00.15\Qualità\"
     newPath = "\\XenFs02\gruppi\Qualità\"
     For Each mySheet In ActiveWorkbook.Worksheets
          For Each myLink In mySheet.Hyperlinks
                With myLink
                     If InStr(.Address, oldPath) = 1 Then
                           .Address = newPath & Mid(.Address, Len(oldPath) + 1)
                     End If
                End With
          Next myLink
     Next mySheet

End Sub

[Anthony47]

"L'altra volta" avevamo usato questa macro viewtopic.php?f=26&t=107651#p631316

Oggi usiamo questa variante:

Codice: Seleziona tutto

Sub hypeRest2()
Dim Hyp As Hyperlink, I As Long, hypA, olPath As String, nwPath As String
'
olPath = "Qualità"               '<<< La "Chiave" del percorso da mantenere
nwPath = "\\XenFS01\Gruppi\"     '<<< Il "percorso" da impostare
'For I = 1 To Worksheets.Count
    For Each Hyp In Sheets("VENDOR LIST").Hyperlinks
        hypA = Hyp.Address
        qpos = InStr(1, hypA, olPath, vbTextCompare)
        If qpos > 0 Then
            Hyp.Address = nwPath & Mid(hypA, qpos) '   Replace(hypA, olPath, nwPath, , , vbTextCompare)
        End If
    Next Hyp
'Next I
End Sub


Prima di eseguire la macro fai un paio di copie di backup del file originale.

Ciao

[giostacchio]

"L'altra volta" avevamo usato questa macro viewtopic.php?f=26&t=107651#p631316

Oggi usiamo questa variante:

Codice: Seleziona tutto

Sub hypeRest2()
Dim Hyp As Hyperlink, I As Long, hypA, olPath As String, nwPath As String
'
olPath = "Qualità"               '<<< La "Chiave" del percorso da mantenere
nwPath = "\\XenFS01\Gruppi\"     '<<< Il "percorso" da impostare
'For I = 1 To Worksheets.Count
    For Each Hyp In Sheets("VENDOR LIST").Hyperlinks
        hypA = Hyp.Address
        qpos = InStr(1, hypA, olPath, vbTextCompare)
        If qpos > 0 Then
            Hyp.Address = nwPath & Mid(hypA, qpos) '   Replace(hypA, olPath, nwPath, , , vbTextCompare)
        End If
    Next Hyp
'Next I
End Sub


Prima di eseguire la macro fai un paio di copie di backup del file originale.

Ciao

Grazie Anthony47, semplicemente Fantastico
grandeeeeeeeeeeeee!
funzionaaaaaaaaa!