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
End With
End Sub
fordrules01 wrote:
Dave,
I don't want to report. I do just want to update. Where i liked this code
was that it allowed me to use all the .xls files in a whole directory rather
than individual workbooks. I want to modify it so it does just automatically
update. The reporting of what has been updated may be beneficial but is a
secondary consideration.
Cheers,
Matt
"Dave Peterson" wrote:
I don't understand why you want a report--why not just update the
hyperlinks?????
fordrules01 wrote:
Dave,
I had a look through the link you mentioned and have found some code that i
need help to modify slightly. The code is from Dick Kusleika's post
http://groups.google.com/group/micro...7ae7cd9cf83f34
Unfortunately its from 2002 so i don't fancy my chances of getting a reply
in there. What i want to achieve is to modify the hyperlinks after they have
been identified in this code below.
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
'Change this path to where the workbooks are
MyPath = "C:\Dick\Tester\Test2\"
i = 1
'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
If InStr(HL.Address, "NewTest") 0 Then
With ThisWorkbook.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
Better yet, if someone can also tell me how to make have it allow a user to
input the path of the folder before it runs that would be ideal.
Cheers.
Matt
"Dave Peterson" wrote:
One thing that could cause trouble is that
application.worksheetfunction.substitute is case sensitive.
So if your links actually contained /matt or /MaTt, then the code would not work
as expected.
If you're using xl2k or higher, you could use Replace instead of
application.worksheetfunction.substitute.
Take a look at David McRitchie's site:
http://www.mvps.org/dmcritchie/excel/buildtoc.htm
look for:
Fix Hyperlinks (#FixHyperlinks)
========
If this doesn't help, you may want to post back with samples (directly copied
from the insert hyperlink dialog) and pasted into your message.
fordrules01 wrote:
Hi,
Completely new to VBA in Excel. I've got a large number of excel files
(approx 600) all which contain up to 20 hyperlinks to drawings and other
files contained on a workgrouped computer. Due to the computer crashing we
have had to move all these drawings to another computer and i need to find a
way to update what is potentially 12,000 hyperlinks. (i'm aware that the
setup of these computers is by no means ideal)
Anyway i've tried to copy some vba off the microsoft site with no luck as
yet. If anyone can find the error or has a better solution please let me know.
Code below: (http://support.microsoft.com/default...b;en-us;247507)
Sub HyperLinkChange()
Dim oldtext As String
Dim newtext As String
Dim h As Hyperlink
' These can be any text portion of a hyperlink, such as ".com" or ".org".
oldtext = "/Matt"
newtext = "/Bob"
' Check all hyperlinks on active sheet.
For Each h In ActiveSheet.Hyperlinks
x = InStr(1, h.Address, oldtext)
If x 0 Then
If h.TextToDisplay = h.Address Then
h.TextToDisplay = newtext
End If
h.Address = Application.WorksheetFunction. _
Substitute(h.Address, oldtext, newtext)
End If
Next
End Sub
Cheers
--
Dave Peterson
--
Dave Peterson
--
Dave Peterson