This seemed to work ok for me. But I think I'd copy a few workbooks to a
separate folder to test it out a little before I did all the work for real.
Option Explicit
Sub testme01()
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
reportOrUpdate = MsgBox(prompt:="No for Report only" & vbLf _
& "Yes for both report and update",
Buttons:=vbYesNo)
Set logWks = Workbooks.Add(1).Worksheets(1)
With logWks
.Name = "Log_" & Format(Now, "yyyymmdd_hhmmss")
.Range("a1:c1").Value _
= Array("Sequence", "WorkbookName", "Links")
End With
oRow = 1
myOldLinkFolder = "X:\budget\"
myNewLinkFolder = "G:\vol4\budget\"
myPath = "c:\my documents\excel\test"
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If
myFile = Dir(myPath & "*.xls")
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 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
logWks.Cells(oRow, 2).Value = myPath & myFiles(fCtr)
logWks.Cells(oRow, 3).Value = "Error opening workbook"
Else
With tempWkbk
myLinks = .LinkSources
If IsArray(myLinks) Then
oRow = oRow + 1
logWks.Cells(oRow, 2).Resize(UBound(myLinks)).Value _
= myPath & myFiles(fCtr)
logWks.Cells(oRow, 3).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
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
logWks.Cells(oRow, 2).Value = myPath & myFiles(fCtr)
logWks.Cells(oRow, 3).Value = "No Links"
End If
.Close SaveChanges:=False
End With
End If
Next fCtr
logWks.UsedRange.Columns.AutoFit
Else
logWks.Parent.Close SaveChanges:=False
End If
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
there are three lines to change:
myOldLinkFolder = "X:\budget\"
myNewLinkFolder = "G:\vol4\budget\"
myPath = "c:\my documents\excel\test"
The myPath variable is where the workbooks to update are located.
===
This doesn't do a lot of checking. It just looks to see if there's a match in
the link folder to the myoldlinkfolder variable.
But since you're changing drives, it should be ok.
But watch out for:
myOldLinkFolder = "c:\my documents\"
myNewLinkFolder = "c:\my documents\test1\"
If you run it a second time, it'll try to make the link point at:
c:\my documents\test1\test1\
The macro just replaced "c\my documents\" with this "c:\my documents\test1\" a
second time. If you think you'll ever have "replacements" like this, you'll
have to be more careful.
And you didn't ask for this, but I think that this a very nice utility for
working with links:
(From Bill Manville.)
Findlink.zip from
http://www.BMSLtd.co.uk/mvp