M
mikeb1690
Hi - i'm newbie to excel vba and could really do with some hel
please.
Thanks to this board, ive found some excellent code to find and replac
links between excel spreadsheets (ive been able to tailor it a bit fo
my own needs). At the minute it only searches and replaces on .xl
files in one folder (not subfolders) ....Problem is i've got hundred
of folders/subfolders i need to run this against and links to fix.
Is ther any quick way of adding a loop to cover subfolders too?
Here's what ive got so far:
TIA,
Mike.
Option Explicit
Sub replace_excel_links()
Application.ScreenUpdating = False
Dim myFiles() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim tempWkbk As Workbook
Dim logWks As Worksheet
Dim oRow As Long
Dim myLinks As Variant
Dim linkCtr As Long
Dim myOldLinkFolder As String
Dim myNewLinkFolder As String
Dim myNewLink As String
Dim reportOrUpdate As Long
'folderpath has been added as a way of showing mypath minus the / i
the log report----------
Dim Folderpath As String
'This is the input text box defining mypath (the folder in which t
search)--------------
myPath = InputBox("Please enter the Folder Pathname: e.g. T:\Folder"
"Enter pathname", "V:\Folder")
If (myPath = "") Then
MsgBox "You must enter a valid pathname (for exampl
T:\Folder\subfolder)", vbCritical + vbOKCancel, "Error"
Exit Sub
End If
'This is the input text box defining myOldLinkFolder (the ol
pathname)--------------
myOldLinkFolder = InputBox("what do you want to replace: e.g
T:\Folder", "old pathname", "T:\Folder")
If (myOldLinkFolder = "") Then
MsgBox "Please enter a valid search term (for exampl
T:\Folder\subfolder)", vbExclamation + vbOKCancel, "Warning"
Exit Sub
End If
'This is the input text box defining myOldLinkFolder (the ol
pathname)--------------
myNewLinkFolder = InputBox("what do you want to replace it with: e.g
T:\new\Folder", "new pathname", "V:\Folder")
If (myNewLinkFolder = "") Then
MsgBox "Please enter a valid replacement pathname (for exampl
T:\new\Folder\subfolder)", vbExclamation + vbOKCancel, "Warning"
Exit Sub
End If
reportOrUpdate = MsgBox(prompt:="Are you sure you want to continue wit
the replacement of" & vbLf & vbLf & myOldLinkFolder & vbLf & "with"
vbLf & myNewLinkFolder & vbLf & vbLf & "Click No to generate a repor
on links only" & vbLf & "Click Yes to proceed with replacement"
Buttons:=vbYesNo)
'Folderpath is added so that it lists mypath without \ at the end i
report--------------
Folderpath = myPath
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If
myFile = Dir(myPath & "*.xls")
If myFile = "" Then
MsgBox "No excel files found", vbExclamation + vbOKCancel, "Warning"
Exit Sub
End If
'this sets up the workbook logwks in which to store the searc
results---------------------
Set logWks = Workbooks.Add(1).Worksheets(1)
With logWks
.Name = "Find_" & Format(Now, "(e-mail address removed)")
.Range("a1:f1").Value = Array("Item", "Folder", "Search text"
"replacement text", "File Name", "Link Path Before Replacement")
End With
oRow = 1
'The following gets the list o
files--------------------------------------------------------
fCtr = 0
Do While myFile <> ""
fCtr = fCtr + 1
ReDim Preserve myFiles(1 To fCtr)
myFiles(fCtr) = myFile
myFile = Dir()
Loop
If fCtr > 0 Then
For fCtr = LBound(myFiles) To UBound(myFiles)
Application.StatusBar _
= "Processing: " & myFiles(fCtr) & " at: " & Now
Set tempWkbk = Nothing
On Error Resume Next
Application.EnableEvents = False
Set tempWkbk = Workbooks.Open(Filename:=myPath & myFiles(fCtr), _
UpdateLinks:=0)
Application.EnableEvents = True
On Error GoTo 0
If tempWkbk Is Nothing Then
'couldn't open it for some reason
oRow = oRow + 1
'The Following line added to give folder pat
name---------------------------------------------
logWks.Cells(oRow, 2).Value = Folderpath
logWks.Cells(oRow, 3).Value = myOldLinkFolder
logWks.Cells(oRow, 4).Value = myNewLinkFolder
logWks.Cells(oRow, 5).Value = myPath & myFiles(fCtr)
logWks.Cells(oRow, 6).Value = "Error opening this excel file (check if
it's password protected)"
Else
With tempWkbk
myLinks = .LinkSources
If IsArray(myLinks) Then
oRow = oRow + 1
'The Following line added to give folder path
name---------------------------------------------
logWks.Cells(oRow, 2).Resize(UBound(myLinks)).Value = Folderpath
logWks.Cells(oRow, 3).Resize(UBound(myLinks)).Value = myOldLinkFolder
logWks.Cells(oRow, 4).Resize(UBound(myLinks)).Value = myNewLinkFolder
logWks.Cells(oRow, 5).Resize(UBound(myLinks)).Value = myPath &
myFiles(fCtr)
logWks.Cells(oRow, 6).Resize(UBound(myLinks)).Value =
Application.Transpose(myLinks)
oRow = oRow + UBound(myLinks) - 1
If reportOrUpdate = vbYes Then
For linkCtr = LBound(myLinks) To UBound(myLinks)
If InStr(1, myLinks(linkCtr), myOldLinkFolder, vbTextCompare) > 0 Then
'This is where the text replacement takes place
------------------------------------------------
myNewLink = Application.Substitute(myLinks(linkCtr), myOldLinkFolder,
myNewLinkFolder)
.ChangeLink Name:=myLinks(linkCtr), newName:=myNewLink,
Type:=xlExcelLinks
End If
Next linkCtr
.Save
End If
Else
oRow = oRow + 1
'The Following line added to give folder path
name---------------------------------------------
logWks.Cells(oRow, 2).Value = Folderpath
logWks.Cells(oRow, 3).Value = myOldLinkFolder
logWks.Cells(oRow, 4).Value = myNewLinkFolder
logWks.Cells(oRow, 5).Value = myPath & myFiles(fCtr)
logWks.Cells(oRow, 6).Value = "No links to other excel files from this
one"
End If
.Close SaveChanges:=False
End With
End If
Next fCtr
logWks.UsedRange.Columns.AutoFit
Else
logWks.Parent.Close SaveChanges:=False
End If
'populate the log file logwks with the
results------------------------------------------------
With logWks
With .Range("a2:a" & .Cells(.Rows.Count, "B").End(xlUp).Row)
.Formula = "=row()-1"
.Value = .Value
End With
End With
With Application
.ScreenUpdating = True
.StatusBar = False
End With
End Sub
please.
Thanks to this board, ive found some excellent code to find and replac
links between excel spreadsheets (ive been able to tailor it a bit fo
my own needs). At the minute it only searches and replaces on .xl
files in one folder (not subfolders) ....Problem is i've got hundred
of folders/subfolders i need to run this against and links to fix.
Is ther any quick way of adding a loop to cover subfolders too?
Here's what ive got so far:
TIA,
Mike.
Option Explicit
Sub replace_excel_links()
Application.ScreenUpdating = False
Dim myFiles() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim tempWkbk As Workbook
Dim logWks As Worksheet
Dim oRow As Long
Dim myLinks As Variant
Dim linkCtr As Long
Dim myOldLinkFolder As String
Dim myNewLinkFolder As String
Dim myNewLink As String
Dim reportOrUpdate As Long
'folderpath has been added as a way of showing mypath minus the / i
the log report----------
Dim Folderpath As String
'This is the input text box defining mypath (the folder in which t
search)--------------
myPath = InputBox("Please enter the Folder Pathname: e.g. T:\Folder"
"Enter pathname", "V:\Folder")
If (myPath = "") Then
MsgBox "You must enter a valid pathname (for exampl
T:\Folder\subfolder)", vbCritical + vbOKCancel, "Error"
Exit Sub
End If
'This is the input text box defining myOldLinkFolder (the ol
pathname)--------------
myOldLinkFolder = InputBox("what do you want to replace: e.g
T:\Folder", "old pathname", "T:\Folder")
If (myOldLinkFolder = "") Then
MsgBox "Please enter a valid search term (for exampl
T:\Folder\subfolder)", vbExclamation + vbOKCancel, "Warning"
Exit Sub
End If
'This is the input text box defining myOldLinkFolder (the ol
pathname)--------------
myNewLinkFolder = InputBox("what do you want to replace it with: e.g
T:\new\Folder", "new pathname", "V:\Folder")
If (myNewLinkFolder = "") Then
MsgBox "Please enter a valid replacement pathname (for exampl
T:\new\Folder\subfolder)", vbExclamation + vbOKCancel, "Warning"
Exit Sub
End If
reportOrUpdate = MsgBox(prompt:="Are you sure you want to continue wit
the replacement of" & vbLf & vbLf & myOldLinkFolder & vbLf & "with"
vbLf & myNewLinkFolder & vbLf & vbLf & "Click No to generate a repor
on links only" & vbLf & "Click Yes to proceed with replacement"
Buttons:=vbYesNo)
'Folderpath is added so that it lists mypath without \ at the end i
report--------------
Folderpath = myPath
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If
myFile = Dir(myPath & "*.xls")
If myFile = "" Then
MsgBox "No excel files found", vbExclamation + vbOKCancel, "Warning"
Exit Sub
End If
'this sets up the workbook logwks in which to store the searc
results---------------------
Set logWks = Workbooks.Add(1).Worksheets(1)
With logWks
.Name = "Find_" & Format(Now, "(e-mail address removed)")
.Range("a1:f1").Value = Array("Item", "Folder", "Search text"
"replacement text", "File Name", "Link Path Before Replacement")
End With
oRow = 1
'The following gets the list o
files--------------------------------------------------------
fCtr = 0
Do While myFile <> ""
fCtr = fCtr + 1
ReDim Preserve myFiles(1 To fCtr)
myFiles(fCtr) = myFile
myFile = Dir()
Loop
If fCtr > 0 Then
For fCtr = LBound(myFiles) To UBound(myFiles)
Application.StatusBar _
= "Processing: " & myFiles(fCtr) & " at: " & Now
Set tempWkbk = Nothing
On Error Resume Next
Application.EnableEvents = False
Set tempWkbk = Workbooks.Open(Filename:=myPath & myFiles(fCtr), _
UpdateLinks:=0)
Application.EnableEvents = True
On Error GoTo 0
If tempWkbk Is Nothing Then
'couldn't open it for some reason
oRow = oRow + 1
'The Following line added to give folder pat
name---------------------------------------------
logWks.Cells(oRow, 2).Value = Folderpath
logWks.Cells(oRow, 3).Value = myOldLinkFolder
logWks.Cells(oRow, 4).Value = myNewLinkFolder
logWks.Cells(oRow, 5).Value = myPath & myFiles(fCtr)
logWks.Cells(oRow, 6).Value = "Error opening this excel file (check if
it's password protected)"
Else
With tempWkbk
myLinks = .LinkSources
If IsArray(myLinks) Then
oRow = oRow + 1
'The Following line added to give folder path
name---------------------------------------------
logWks.Cells(oRow, 2).Resize(UBound(myLinks)).Value = Folderpath
logWks.Cells(oRow, 3).Resize(UBound(myLinks)).Value = myOldLinkFolder
logWks.Cells(oRow, 4).Resize(UBound(myLinks)).Value = myNewLinkFolder
logWks.Cells(oRow, 5).Resize(UBound(myLinks)).Value = myPath &
myFiles(fCtr)
logWks.Cells(oRow, 6).Resize(UBound(myLinks)).Value =
Application.Transpose(myLinks)
oRow = oRow + UBound(myLinks) - 1
If reportOrUpdate = vbYes Then
For linkCtr = LBound(myLinks) To UBound(myLinks)
If InStr(1, myLinks(linkCtr), myOldLinkFolder, vbTextCompare) > 0 Then
'This is where the text replacement takes place
------------------------------------------------
myNewLink = Application.Substitute(myLinks(linkCtr), myOldLinkFolder,
myNewLinkFolder)
.ChangeLink Name:=myLinks(linkCtr), newName:=myNewLink,
Type:=xlExcelLinks
End If
Next linkCtr
.Save
End If
Else
oRow = oRow + 1
'The Following line added to give folder path
name---------------------------------------------
logWks.Cells(oRow, 2).Value = Folderpath
logWks.Cells(oRow, 3).Value = myOldLinkFolder
logWks.Cells(oRow, 4).Value = myNewLinkFolder
logWks.Cells(oRow, 5).Value = myPath & myFiles(fCtr)
logWks.Cells(oRow, 6).Value = "No links to other excel files from this
one"
End If
.Close SaveChanges:=False
End With
End If
Next fCtr
logWks.UsedRange.Columns.AutoFit
Else
logWks.Parent.Close SaveChanges:=False
End If
'populate the log file logwks with the
results------------------------------------------------
With logWks
With .Range("a2:a" & .Cells(.Rows.Count, "B").End(xlUp).Row)
.Formula = "=row()-1"
.Value = .Value
End With
End With
With Application
.ScreenUpdating = True
.StatusBar = False
End With
End Sub