Find dependent workbooks

  • Thread starter Thread starter Dom Boyce
  • Start date Start date
D

Dom Boyce

Hi,

does anybody know of any existing code to find all the workbooks
dependent on the current workbook? I assume such code would need user
input as to which folders to look in, would then open one-by-one all
..xls files in that folder, and check all cells for the string name of
the current workbook. I would attempt writing the code for myself,
only I know it will take me ages, as I am not the best at VBA.

Any help much appreciated

Dom
 
You can find the references/links that a workbook uses by: Edit|links.

But finding the links in the other direction is opening each and checking to see
if it used it. And these files could be anywhere on your local harddrive(s),
(even) floppies, CD ROMS, Network drives....

And if the file is on a network drive the link could be via a mapped drive (like
M:\myfolder\myfile.xls) or via the UNC name:
\\myserver\mysharename\myfolder\myfile.xls

And both of those could be pointing at the same file.

But with all those admonitions, maybe this'll get you started. It just looks
for the C:\path\filename.xls within a link. If found, it adds it to a report
worksheet.

It only looks at one folder at a time. But you can run it against as many
folders as you want.

If you save this macro in a workbook, then don't store it in the same folder as
you're searching. I didn't put any check to make sure that the code doesn't try
to re-open itself (but you could add it if you want).



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 myLinkName As String
'Change what to look for here!
myLinkName = "C:\my documents\excel\book1.xls"

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

'change to point at the folder to check
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

oRow = oRow + 1
logWks.Cells(oRow, 2).Value = myPath & myFiles(fCtr)

If tempWkbk Is Nothing Then
'couldn't open it for some reason
logWks.Cells(oRow, 3).Value = "Error opening workbook"
Else
With tempWkbk
myLinks = .LinkSources
If IsArray(myLinks) Then
For linkCtr = LBound(myLinks) To UBound(myLinks)
If LCase(myLinks(linkCtr)) = LCase(myLinkName) Then
logWks.Cells(oRow, 3).Value _
= "Has Link to: " & myLinkName
End If
Next linkCtr
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
 
Hi John,
Learn to use your news browser, but even if you do not have it
because some postings do get lost there is Google Groups...

That is a question you can answer yourself by looking in the
Google Groups archives. By searching on the message-id
for a posting within the thread or if it was related to a posting
of your by searching on your email address and then looking at
the thread. More information:
Excel Newsgroups & Searching Newsgroups
http://www.mvps.org/dmcritchie/excel/xlnews.htm

The thread for the post you are in (takes 12 hours to get to Google)
http://google.com/[email protected]

Because the posting was long you are told to look for the rest of the posting at
http://www.google.com/[email protected]
which is all the more reason that the code should not be reposted, because
it can be referenced. And that is what people should find when they search
for their own solutions.

Since you are using Outlook Express you can find some help in using
Outlook Express at
http://www.mvps.org/dmcritchie/ie/oe6.htm
You can select the posting you are interested in looking at the entire thread of,
then use View, Current View, Show All then go back to
the view you were in. Other newsbrowsers would have features
to look at the entire thread as well.

Being able to see the headers for posting and for email is essential
http://www.mvps.org/dmcritchie/ie/oe6.htm#headers

HTH,
David McRitchie, Microsoft MVP - Excel [site changed Nov. 2001]
My Excel Pages: http://www.mvps.org/dmcritchie/excel/excel.htm
Search Page: http://www.mvps.org/dmcritchie/excel/search.htm
 
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 myLinkName As String
'Change what to look for here!
myLinkName = "C:\my documents\excel\book1.xls"

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

'change to point at the folder to check
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

oRow = oRow + 1
logWks.Cells(oRow, 2).Value = myPath & myFiles(fCtr)

If tempWkbk Is Nothing Then
'couldn't open it for some reason
logWks.Cells(oRow, 3).Value = "Error opening workbook"
Else
With tempWkbk
myLinks = .LinkSources
If IsArray(myLinks) Then
For linkCtr = LBound(myLinks) To UBound(myLinks)
If LCase(myLinks(linkCtr)) = LCase(myLinkName)
Then
logWks.Cells(oRow, 3).Value _
= "Has Link to: " & myLinkName
End If
Next linkCtr
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
 
Back
Top