converting hyperlink paths

[Bill Sigl]

I have an excel spreadsheet with hundreds of hyperlinks to pictures. These
pictures were stored in about 30 folders, so the hyperlinks contain the
paths to the pictures.

I have moved all the pictures, and the spreadsheet from 1 computer to
another. How can I write a script (VBA?) to go thur all the cells on each
worksheet looking for a hyperlink.
When a hyperlink is found it would parse the hyperlink and then access a
list to tell it how to convert the path of the hyperlink to reflect the
location of the picture on the new computer?

 

[William]

Hi

3 parts to this:

1) Find out where the "old" hyperlinks are in the active sheet (assumed it
is called "Sheet1"). To do this run "OldHyperlinks" which creates a new
sheet called Hypers. Column A and B of "Hypers" contain the cell address and
path of each hyperlink in Sheet1.
2) Amend Column B of "Hypers" to deal with the new path of each hyperlink.
3) Run "NewHyperlinks" to insert the new hyperlink paths on Sheet1.


Sub OldHyperlinks()
Application.ScreenUpdating = False
On Error Resume Next
Dim r As Range, c As Range, l As Long
Dim ws As Worksheet, s As String
Set r = Sheets("Sheet1").UsedRange
Set ws = Sheets.Add
ws.Name = "Hypers"
For Each c In r
s = c.Address
l = 0
l = Len(c.Hyperlinks(1).Address)
If l > 1 Then
ws.Range("A65000").End(xlUp).Offset(1, 0) = s
ws.Range("A65000").End(xlUp).Offset(0, 1) = _
c.Hyperlinks(1).Address
ws.Columns("A:A").Replace What:="$", _
Replacement:="", LookAt:=xlPart
End If
Next c
Application.ScreenUpdating = True
End Sub

Sub NewHyperlinks()
Application.ScreenUpdating = False
On Error Resume Next
Dim r As Range, c As Range
Dim s As String, str As String
With Sheets("Hypers")
Set r = .Range(.Range("A2"), _
..Range("A" & Rows.Count).End(xlUp))
End With
With Sheets("Sheet1")
For Each c In r
str = c.Offset(0, 1)
s = .Range(c).Text
..Range(c).Hyperlinks.Add Anchor:=.Range(c), _
Address:=str
..Range(c) = s
Next c
End With
Application.DisplayAlerts = False
Sheets("Hypers").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

--

XL2003
Regards

William
(e-mail address removed)

 

[William]

Bill

Just noticed that you want to carry out the process for all worksheets in
the workbook - use these subs instead

Sub OldHyperlinks()
Application.ScreenUpdating = False
On Error Resume Next
Dim r As Range, c As Range, l As Long
Dim ws As Worksheet, s As String
Dim ws1 As Worksheet
Set ws = Sheets.Add
ws.Name = "Hypers"
For Each ws1 In Worksheets
If Not ws1.Name = "Hypers" Then
Set r = ws1.UsedRange
For Each c In r
s = c.Address
l = 0
l = Len(c.Hyperlinks(1).Address)
If l > 1 Then
ws.Range("A65000").End(xlUp).Offset(1, 0) = s
ws.Range("A65000").End(xlUp).Offset(0, 1) = _
c.Hyperlinks(1).Address
ws.Range("A65000").End(xlUp).Offset(0, 2) = _
ws1.Name
End If
Next c
End If
Next ws1
ws.Columns("A:A").Replace What:="$", _
Replacement:="", LookAt:=xlPart
Application.ScreenUpdating = True
End Sub

Sub NewHyperlinks()
Application.ScreenUpdating = False
On Error Resume Next
Dim r As Range, c As Range
Dim s As String, str As String
Dim stg As String
With Sheets("Hypers")
Set r = .Range(.Range("A2"), _
..Range("A" & Rows.Count).End(xlUp))
End With
For Each c In r
str = c.Offset(0, 1)
stg = c.Offset(0, 2)
s = Sheets(stg).Range(c).Text
Sheets(stg).Range(c).Hyperlinks.Add Anchor:= _
Sheets(stg).Range(c), Address:=str
Sheets(stg).Range(c) = s
Next c
Application.DisplayAlerts = False
Sheets("Hypers").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

--


XL2003
Regards

William
(e-mail address removed)