Oh...

forget to tell you that DON'T put this file into that working directory, as
macros involve open and close those files with hyperlink.

Simply put it other place and try again.

"fordrules01" wrote:

Thankyou very much to both of you.

Leung; I believe this is exactly what i'm after but so far have had no luck
getting it to work. I'm a novice with VBA so it may be something very simple
i'm doing wrong. I'll try to explain every step i took in detail.

1) copied the code below into a new module in a new workbook "Master
Hyperlink Rename.xls"
2) Set up a folder "C:\Documents and Settings\Matt\Desktop\Test\" which
contained 2 test workbooks with hyperlinks (hyperlinked to picture/word files
in the same folder)
3) put the text "\Matt\" in A1 , "\Bob\" in A2, "C:\Documents and
Settings\Matt\Desktop\Test\" in A3 (Note: unsure of whether these actually
need "" around them or not but no luck either way)
4) Went to Tools Macro Macros.. and chose "Do All" and selected Run

Now heres where i got a couple of different problems.
- First, when the Master Hyperlink Rename.xls was outside the specified
folder it appeared to run something and then popped up asking if i wanted to
reopen Master Hyperlink Rename.xls and any changes would be lost.
- Second, when Master Hyperlink Rename was located inside the folder i was
wanting to modify i get the error (after it momentarily shows up a whole heap
of text in my worksheet) saying "Run-time error '1004': " could not be founf.
Check the spelling of the file name, and verify that the file location is
correct."

Any help on this would be appreciated.




"Leung" wrote:

Hi

I have created 3 Sub as below, just copy and paste to module section.
Input cells A1, A2 and A3, see below instruction.
Call the DoAll() or call it individually.

regards

Leung


==code start ==

'Three Steps:
Sub DoAll()

'please make sure A1, A2 and A3 is not empty

'Step 1 - list all hyperlink for all excels from path in cell A3 e.g.
"C:\test\"
Call FindHlinks

'Step 2 - list of hyperlink to be change from cell A1 to A2
'A1 "../abc/", "http://msn.com"
'A2 "../bcd/", "http://www.msn.com/"

Call CreateHyperlinkList

'Step 3 - Replace all
Call ReplaceAllHyperlink

End Sub



'==
'Discover all hyperlinks in a folder of spreadsheets
Sub FindHlinks()

Dim MyPath As String
Dim HL As Hyperlink
Dim sh As Worksheet
Dim Currfile As String
Dim CurrWb As Workbook
Dim i As Integer


strLookForPath = Range("A1").Value
strReplaceForPath = Range("A2").Value
MyPath = Range("A3").Value


'row to start to write down hyperlink information
i = 5

'Find the first xls file in the directory
Currfile = Dir(MyPath & "*.xls")


'Do while there is at least one xls file
Do While Currfile < ""
'Open the file
Set CurrWb = Workbooks.Open(MyPath & Currfile)
'Cycle through the sheets
For Each sh In CurrWb.Worksheets
'Cycle through the hyperlinks on the sheet
For Each HL In sh.Hyperlinks
'See if the name of your backup directory is in
'the hlink address. I searched for NewTest, but
'you will want to search for the name of your
'own backup directory
'+Previous If InStr(HL.Address, "NewTest") 0 Then
If InStr(HL.Address, strLookForPath) 0 Then
' With ThisWorkbook.Sheets(1)
' +added write to current sheet
With Workbooks("change_link.xls").Sheets(1)
'Write the info to cells
.Cells(i, 1) = CurrWb.Name
.Cells(i, 2) = sh.Name
.Cells(i, 3) = HL.Address
.Cells(i, 4) = HL.Range.Address
End With
i = i + 1
End If
Next HL
Next sh
'Close the workbook
CurrWb.Close False
'Find the next xls file
Currfile = Dir
Loop


Set CurrWb = Nothing
Set sh = Nothing
Set HL = Nothing

End Sub

' This copy and paste the col C into Col D with string replacement
' from Cell a1 to a2
Sub CreateHyperlinkList()

Dim strLookForPath As String
Dim strReplaceForPath As String

strLookForPath = Range("A1")
strReplaceForPath = Range("A2")


'existing link should start with cell C5
'copy all hyperlinks
Range("C5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'put it starting from cell E5
Range("E5").Select
ActiveSheet.Paste

Selection.Replace What:=strLookForPath,
Replacement:=strReplaceForPath, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False

Range("E5").Select
Application.CutCopyMode = False


End Sub


'Perform this to replace all hyperlink
'remember to change the path

Sub ReplaceAllHyperlink()

'select range and it should start with A5
Range("A5").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select

Dim strPara() As String
Dim i As Long

i = 1

Do While i <= Selection.Rows.Count
'do it one by one


'++change this
strMyPath = Range("A3").Value

Call ReplaceSingleHyperlink(strMyPath, _
Selection.Cells(i, 1).Value, _
Selection.Cells(i, 2).Value, _
Selection.Cells(i, 4).Value, _
Selection.Cells(i, 5).Value)
i = i + 1

Loop

End Sub


'this make the procedure more generic and reusable
Sub ReplaceSingleHyperlink(ByVal strMyPath As String, _
ByVal strWorkBookName As String, _
ByVal strSheetname As String, _
ByVal strAddress As String, _
ByVal strNewLink As String)

'no need to blinking
Application.ScreenUpdating = False

'replace one by one
Workbooks.Open (strMyPath & strWorkBookName)

ActiveWorkbook.Sheets(strSheetname).Range(strAddre ss).Hyperlinks(1).Address =
strNewLink
ActiveWorkbook.Save
ActiveWorkbook.Close


End Sub


==code end ==






"Dave Peterson" wrote:

I would spend some time getting the macro that fixed one worksheet's hyperlinks
working. Then advance to multiple sheets, then multiple workbooks.

But maybe you can modify this:

Option Explicit
Sub testme01()

Dim myNames() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim wkbk As Workbook
Dim wks As Worksheet
Dim DestCell As Range
Dim RngToCopy As Range

Dim OldStr As String
Dim NewStr As String
Dim hyp As Hyperlink

OldStr = "http://192.168.15.5/"
NewStr = "http://hank.home.on.ca/"

Application.ScreenUpdating = False

'change the folder here
myPath = "C:\my documents\excel\test"
If myPath = "" Then Exit Sub
If Right(myPath, 1) < "\" Then
myPath = myPath & "\"
End If

myFile = ""
On Error Resume Next
myFile = Dir(myPath & "*.xls")
On Error GoTo 0
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If

'get the list of files
fCtr = 0
Do While myFile < ""
fCtr = fCtr + 1
ReDim Preserve myNames(1 To fCtr)
myNames(fCtr) = myFile
myFile = Dir()
Loop

If fCtr 0 Then
For fCtr = LBound(myNames) To UBound(myNames)
Application.StatusBar _
= "Processing: " & myNames(fCtr) & " at: " & Now
Set wkbk = Workbooks.Open(Filename:=myPath & myNames(fCtr))

For Each wks In wkbk.Worksheets
For Each hyp In ActiveSheet.Hyperlinks
hyp.Address = Replace(hyp.Address, OldStr, NewStr)
Next hyp
Next wks

wkbk.Close savechanges:=True

Next fCtr
End If

With Application
.ScreenUpdating = True
.StatusBar = False