Ik ben de link waar ik het vandaan gehaald heb kwijt maar hieronder de volledige code.
De credits zijn niet voor mij maar voor de maker Gary Brown.
'This code will create a worksheet that lists all references to links. It
'will also create hyperlinks to those cells to make it very easy to locate
'them. The hyperlinks won't go to a hidden worksheet, however.
'HTH,
'Gary Brown
'Kinneson Consulting
'Code starts here
Option Explicit
Option Compare Text
'Version 1a: 01/2000 - ranges included in search
'Version 2.0: 03/21/2000 - names of sheets in workbook included in search
'Version 3.0: 04/20/2000 - DrawingObjects in workbook included in search
' Note: V3.0 DrawingObjects methodology strongly influenced by
' Bill Manville's FindLink.xla
'Version 3.1: 06/06/2000 for recognition of ErrorTypes
'Version 3.2: 06/14/2000 - account for mis-formatting when there are
' hidden sheets
'Version 3.3: 07/06/2000 - add hyperlink to appropriate addresses
'
Const constVersion = "3.3"
'=========================================================
Public Sub SearchFinder()
On Error Resume Next
'Purpose of this VBA program is to find and list all searched for items
'in a Workbook
'
'Note: calls funcErrorType
'
'Ctrl-Shift-S to run this macro
' For use with EXCEL 97 or higher
'
Dim aryHiddensheets()
Dim bTrueFalse1 As Boolean, bTrueFalse As Boolean
Dim iRow As Double, iColumn As Double, dblLastRow
Dim iFormulaCount As Double, iTextValuesCount As Double
Dim i As Integer, iErrorTest As Integer
Dim x As Integer, y As Integer, iWorksheets As Integer
Dim nName As Name
Dim objOutputArea As Object, objCell As Object
Dim objRangeWithTextAndValues As Object
Dim objRangeWithFormulas As Object, obj As Object
Dim strInputQuestion As String, strResultsTableName As String
Dim strWorksheetName As String, strWorksheetType As String
Dim varAnswer As Variant, varCellFormula As Variant
Dim varLookFor As Variant, varLookFor_Original As Variant
Dim varErrorTest As Variant
strResultsTableName = "Results_Table"
strInputQuestion = "What are you Looking for?" & vbCr & "To find references to other spreadsheets, type " & Chr(34) & _
".xls" & Chr(34) & vbCr & _
"To review other " & Chr(39) & "Errors" & Chr(39) & ", try:" & _
vbCr & "#N/A or #NAME? or #REF! or #VALUE! or #DIV/0! or #NULL! or #NUM!"
varLookFor_Original = Application.InputBox(strInputQuestion, _
"Search and List - V. " & constVersion, ".xls")
varLookFor = UCase(varLookFor_Original)
If varLookFor_Original = False Then
Exit Sub
End If
strInputQuestion = "You have not entered anything." & Chr(10) & Chr(10) & _
"Note: Continuing will list ALL information in ALL worksheets in the workbook." & _
Chr(10) & Chr(10) & _
"Press Ctrl-Break at any time to break out of this program." & _
Chr(10) & Chr(10) & _
"Do you wish to continue?"
If Len(varLookFor) = 0 Then
varAnswer = MsgBox(strInputQuestion, vbInformation + vbYesNo + vbDefaultButton2, _
"This could be a VERY lengthy process...!!!")
If varAnswer = vbNo Then
Exit Sub
End If
End If
'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count
'redim array
ReDim aryHiddensheets(1 To iWorksheets)
'put hidden sheets in an array, then unhide the sheets
For x = 1 To iWorksheets
If Worksheets(x).Visible = False Then
aryHiddensheets(x) = Worksheets(x).Name
Worksheets(x).Visible = True
End If
Next
'Check for duplicate Worksheet name
i = ActiveWorkbook.Sheets.Count
For x = 1 To i
If Windows.Count = 0 Then Exit Sub
If UCase(Worksheets(x).Name) = UCase(strResultsTableName) Then
Worksheets(x).Activate
If Err.Number = 9 Then
Exit For
End If
Application.DisplayAlerts = False 'turn warning messages off
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True 'turn warning messages on
'Exit Sub
End If
Next
'Add new worksheet at end of workbook
' where results will be located
Worksheets.Add.Move After:=Worksheets(Worksheets.Count)
'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.Name = strResultsTableName
ActiveWorkbook.ActiveSheet.Range("A1").Value = "Worksheet"
ActiveWorkbook.ActiveSheet.Range("B1").Value = "Address"
ActiveWorkbook.ActiveSheet.Range("C1").Value = "Type"
ActiveWorkbook.ActiveSheet.Range("D1").Value = "Results Found"
ActiveWorkbook.ActiveSheet.Range("E1").Value = "Value"
'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count
'Initialize row and column counts for putting info into strResultsTableName sheet
iRow = 1
iColumn = 0
'Check Sheet names
For x = 1 To iWorksheets
Sheets(x).Activate
strWorksheetName = ActiveSheet.Name
strWorksheetType = UCase(TypeName(ActiveSheet))
If UCase(ActiveSheet.Name) = UCase(strResultsTableName) Then
Exit For
End If
'check to see if a match exists for sheet names
Set objOutputArea = ActiveWorkbook.Sheets(strResultsTableName).Range("A1")
With objOutputArea
If InStr(UCase(strWorksheetName), varLookFor) <> 0 Then
'put information into StrResultstablename worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = ""
.Hyperlinks.Add anchor:=.Offset(iRow, iColumn), _
Address:="", SubAddress:=Chr(39) & ActiveSheet.Name & _
Chr(39) & "!A1"
.Offset(iRow, iColumn + 2) = "W"
.Offset(iRow, iColumn + 3) = " "
Select Case strWorksheetType
Case "CHART"
.Offset(iRow, iColumn + 4) = " Note: CHART"
Case "WORKSHEET"
.Offset(iRow, iColumn + 4) = " Note: WORKSHEET"
Case "DIALOGSHEET"
.Offset(iRow, iColumn + 4) = " Note: DialogSheet"
Case Else
.Offset(iRow, iColumn + 4) = " Note: Type Unknown"
End Select
iRow = iRow + 1
End If
End With
If iRow = 65536 Then
iColumn = iColumn + 5
iRow = 1
End If
Next x
'Go through one Worksheet at a time
For x = 1 To iWorksheets
'Go to Next Worksheet
Worksheets(x).Activate
'Initialize formula and text/value count variables
iFormulaCount = 0
iTextValuesCount = 0
If ActiveWorkbook.ActiveSheet.Name <> strResultsTableName Then
'Identify the cells with formulas and text/values in them
Set objRangeWithTextAndValues = Nothing
Set objRangeWithFormulas = Nothing
'Establish cells with formulas and text/values in them
On Error Resume Next
Set objRangeWithTextAndValues = ActiveSheet.Cells.SpecialCells(xlTextValues)
Set objRangeWithFormulas = ActiveSheet.Cells.SpecialCells(xlFormulas)
iFormulaCount = objRangeWithFormulas.Count
iTextValuesCount = objRangeWithTextAndValues.Count
'if there is text
If iTextValuesCount <> 0 Then
'Process each cell with a value or text in it
Set objOutputArea = ActiveWorkbook.Sheets(strResultsTableName).Range("A1")
For Each objCell In objRangeWithTextAndValues
With objOutputArea
'check to see if a match exists
If InStr(UCase(objCell.Formula), varLookFor) <> 0 Then
'put information into StrResultstablename Worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
.Hyperlinks.Add anchor:=.Offset(iRow, iColumn + 1), _
Address:="", SubAddress:=Chr(39) & ActiveSheet.Name & _
Chr(39) & "!" & objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
.Offset(iRow, iColumn + 2) = "V"
.Offset(iRow, iColumn + 3) = " " & objCell.Formula
.Offset(iRow, iColumn + 4) = " " & objCell.Value
iRow = iRow + 1
End If
End With
If iRow = 65536 Then
iColumn = iColumn + 5
iRow = 1
End If
Next objCell
End If
'if there are formulas
If iFormulaCount <> 0 Then
'Process each cell with a value or text in it
Set objOutputArea = ActiveWorkbook.Sheets(strResultsTableName).Range("A1")
For Each objCell In objRangeWithFormulas
With objOutputArea
'check to see if a match exists
' capture numeric, alpha values and errors from formulas
varErrorTest = funcErrorType(objCell.Value)
iErrorTest = 0
If InStr(UCase(objCell.Formula), varLookFor) <> 0 Then iErrorTest = 1
If InStr(UCase(varErrorTest), varLookFor) <> 0 Then iErrorTest = 2
If Len(varErrorTest) = 0 Then
If InStr(UCase(objCell.Value), varLookFor) <> 0 Then
iErrorTest = 1
End If
End If
If InStr(UCase(objCell.Value), varLookFor) <> 0 Then
If IsError(InStr(UCase(objCell.Value), varLookFor)) Then
If iErrorTest <> 1 And iErrorTest <> 2 Then iErrorTest = 0
End If
End If
If iErrorTest <> 0 Then
'put information into StrResultsTableName Worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
.Hyperlinks.Add anchor:=.Offset(iRow, iColumn + 1), _
Address:="", SubAddress:=Chr(39) & ActiveSheet.Name & _
Chr(39) & "!" & objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
.Offset(iRow, iColumn + 2) = "F"
.Offset(iRow, iColumn + 3) = " " & objCell.Formula
If UCase(varErrorTest) = "" Then
.Offset(iRow, iColumn + 4) = " " & objCell.Value
Else
.Offset(iRow, iColumn + 4) = " " & varErrorTest
End If
iRow = iRow + 1
End If
End With
If iRow = 65536 Then
iColumn = iColumn + 7
iRow = 1
End If
varErrorTest = ""
Next objCell
End If
End If
If ActiveWorkbook.ActiveSheet.Name <> strResultsTableName Then
For Each obj In ActiveSheet.DrawingObjects
' any drawing object
If InStr(obj.OnAction, varLookFor) > 0 Then
With objOutputArea
'check to see if a match exists
'put information into StrResultsTableName worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = " On Action of " & obj.Name
.Hyperlinks.Add anchor:=.Offset(iRow, iColumn + 1), _
Address:="", SubAddress:=Chr(39) & ActiveSheet.Name & _
Chr(39) & "!A1"
.Offset(iRow, iColumn + 2) = "O"
.Offset(iRow, iColumn + 3) = " " & obj.OnAction
.Offset(iRow, iColumn + 4) = ""
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 7
iRow = 1
End If
End If
' some drawing objects have formula properties
bTrueFalse = False 'Have not reviewed this object yet
Select Case TypeName(obj)
Case "TextBox", "Picture", "Button", "Label"
bTrueFalse = False
If TypeName(obj) <> "Label" Then
If InStr(obj.Formula, varLookFor) > 0 Then
bTrueFalse = True
With objOutputArea
'check to see if a match exists
'put information into strResultsTableName Worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = " Formula in " & TypeName(obj) & " - " & obj.Name
.Hyperlinks.Add anchor:=.Offset(iRow, iColumn + 1), _
Address:="", SubAddress:=Chr(39) & ActiveSheet.Name & _
Chr(39) & "!A1"
.Offset(iRow, iColumn + 2) = "O"
.Offset(iRow, iColumn + 3) = " " & obj.Formula
.Offset(iRow, iColumn + 4) = " " & obj.Value
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 7
iRow = 1
End If
End If
End If
' check drawing object name
If bTrueFalse = False Then
If InStr(obj.Name, varLookFor) > 0 Then
With objOutputArea
'check to see if a match exists
'put information into strResultsTableName Worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = TypeName(obj)
.Hyperlinks.Add anchor:=.Offset(iRow, iColumn + 1), _
Address:="", SubAddress:=Chr(39) & ActiveSheet.Name & _
Chr(39) & "!A1"
.Offset(iRow, iColumn + 2) = "O"
.Offset(iRow, iColumn + 3) = " " & obj.Name
.Offset(iRow, iColumn + 4) = ""
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 7
iRow = 1
End If
End If
End If
Case "OLEObject"
bTrueFalse = True
bTrueFalse1 = False ' OLEType not a link
If obj.OLEType = xlOLELink Then ' Linked Object
If Val(Application.Version) >= 8 Then
' in Excel 8 we can check the source of the link
If InStr(obj.SourceName, varLookFor) > 0 Then
bTrueFalse1 = True 'OLEType is a link With varLookFor
With objOutputArea
'check to see if a match exists
'put information into strResultsTableName Worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = " " & obj.Name
.Hyperlinks.Add anchor:=.Offset(iRow, iColumn + 1), _
Address:="", SubAddress:=Chr(39) & ActiveSheet.Name & Chr(39) & "!A1"
.Offset(iRow, iColumn + 2) = "O"
.Offset(iRow, iColumn + 3) = " " & obj.SourceName
.Offset(iRow, iColumn + 4) = ""
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 7
iRow = 1
End If
End If
End If
Else
' check name in Embedded Objects and Linked Objects if
' it was not checked in the above test
If bTrueFalse1 = False Then
If InStr(obj.Name, varLookFor) > 0 Then
With objOutputArea
'check to see if a match exists
'put information into strResultsTableName Worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = " In name of"
.Hyperlinks.Add anchor:=.Offset(iRow, iColumn + 1), _
Address:="", SubAddress:=Chr(39) & ActiveSheet.Name & _
Chr(39) & "!A1"
.Offset(iRow, iColumn + 2) = "O"
.Offset(iRow, iColumn + 3) = " " & obj.Name
.Offset(iRow, iColumn + 4) = ""
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 7
iRow = 1
End If
End If
End If
End If
Case "DropDown", "ListBox"
bTrueFalse = True
bTrueFalse1 = False
If InStr(obj.LinkedCell, varLookFor) > 0 Then
bTrueFalse1 = True
With objOutputArea
'check to see if a match exists
'put information into strResultsTableName Worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = TypeName(obj)
.Hyperlinks.Add anchor:=.Offset(iRow, iColumn + 1), _
Address:="", SubAddress:=Chr(39) & ActiveSheet.Name & _
Chr(39) & "!A1"
.Offset(iRow, iColumn + 2) = "O"
.Offset(iRow, iColumn + 3) = "LinkedCell: " & obj.LinkedCell
.Offset(iRow, iColumn + 4) = " " & obj.Name
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 7
iRow = 1
End If
End If
If bTrueFalse1 = False Then
If InStr(obj.Name, varLookFor) > 0 Then
With objOutputArea
'check to see if a match exists
'put information into strResultsTableName Worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = TypeName(obj)
.Hyperlinks.Add anchor:=.Offset(iRow, iColumn + 1), _
Address:="", SubAddress:=Chr(39) & ActiveSheet.Name & _
Chr(39) & "!A1"
.Offset(iRow, iColumn + 2) = "O"
.Offset(iRow, iColumn + 3) = " " & obj.Name
.Offset(iRow, iColumn + 4) = ""
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 7
iRow = 1
End If
End If
End If
If InStr(obj.ListFillRange, varLookFor) > 0 Then
With objOutputArea
'check to see if a match exists
'put information into strResultsTableName Worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = TypeName(obj)
.Hyperlinks.Add anchor:=.Offset(iRow, iColumn + 1), _
Address:="", SubAddress:=Chr(39) & ActiveSheet.Name & _
Chr(39) & "!A1"
.Offset(iRow, iColumn + 2) = "O"
.Offset(iRow, iColumn + 3) = "ListFillRange: " & obj.ListFillRange
.Offset(iRow, iColumn + 4) = " " & obj.Name
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 7
iRow = 1
End If
End If
Case Else
If bTrueFalse = False Then
If InStr(obj.Name, varLookFor) > 0 Then
With objOutputArea
'check to see if a match exists
'put information into strResultsTableName Worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.Name
.Offset(iRow, iColumn + 1) = TypeName(obj)
.Hyperlinks.Add anchor:=.Offset(iRow, iColumn + 1), _
Address:="", SubAddress:=Chr(39) & ActiveSheet.Name & _
Chr(39) & "!A1"
.Offset(iRow, iColumn + 2) = "O"
.Offset(iRow, iColumn + 3) = " " & obj.Name
.Offset(iRow, iColumn + 4) = ""
iRow = iRow + 1
End With
If iRow = 65536 Then
iColumn = iColumn + 7
iRow = 1
End If
End If
End If
End Select
Next
End If
Next x
'evaluate all ranges in the workbook
For Each nName In ActiveWorkbook.Names
With objOutputArea
bTrueFalse1 = False
If InStr(UCase(nName.Name), varLookFor) <> 0 Then
bTrueFalse1 = True
'put information into StrResultstablename worksheet
.Offset(iRow, iColumn) = " " & nName.Name
.Offset(iRow, iColumn + 1) = ""
.Offset(iRow, iColumn + 2) = "R"
.Offset(iRow, iColumn + 3) = " " & nName.RefersTo
.Offset(iRow, iColumn + 4) = " " & nName.Value
iRow = iRow + 1
End If
If Not bTrueFalse1 Then
If InStr(UCase(nName.RefersTo), varLookFor) <> 0 Then
'put information into StrResultstablename worksheet
.Offset(iRow, iColumn) = " " & nName.Name
.Offset(iRow, iColumn + 1) = ""
.Offset(iRow, iColumn + 2) = "R"
.Offset(iRow, iColumn + 3) = " " & nName.RefersTo
.Offset(iRow, iColumn + 4) = " " & nName.Value
iRow = iRow + 1
End If
End If
End With
Next
'Release all variables from memory
Set objRangeWithTextAndValues = Nothing
Set varCellFormula = Nothing
Set varAnswer = Nothing
Set objOutputArea = Nothing
Set objCell = Nothing
Set objRangeWithTextAndValues = Nothing
'start formatting output
Columns("A:E").Select
Columns("A:E").EntireColumn.AutoFit
'creating comment
With Range("C1")
.Select
.AddComment
.Comment.Shape.Select True
.Comment.Text Text:= _
"Note:" & vbLf & "(F)ormula" & vbLf & "(O)bject" & vbLf & _
"(R)ange" & vbLf & "(V)alue/Text" & vbLf & "(W)orksheet"
Selection.ShapeRange.ScaleHeight 1.74, msoFalse, msoScaleFromTopLeft
.Comment.Visible = False
End With
'continue formatting output
Columns("A:A").Select
If Selection.ColumnWidth > 50 Then
Selection.ColumnWidth = 50
End If
Columns("D
").Select
If Selection.ColumnWidth > 50 Then
Selection.ColumnWidth = 50
End If
Columns("E:E").Select
If Selection.ColumnWidth > 50 Then
Selection.ColumnWidth = 50
End If
Columns("A:A,D:E").Select
With Selection
.WrapText = True
End With
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.WrapText = True
End With
With Selection.Font
.Underline = xlUnderlineStyleSingleAccounting
End With
Range("A2").Select
ActiveWindow.FreezePanes = True
Columns("B:C").Select
With Selection
.HorizontalAlignment = xlCenter
End With
Range("D1").Select
With Selection
.HorizontalAlignment = xlLeft
End With
Range("A:E").Select
With Selection
.VerticalAlignment = xlTop
End With
Range("A1:A1").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
, Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Rows("1:1").Select
Selection.Insert Shift:=xlDown
dblLastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
dblLastRow = dblLastRow - 2
ActiveWorkbook.ActiveSheet.Range("A1").WrapText = False
ActiveWorkbook.ActiveSheet.Range("A1").Value = _
dblLastRow & " hit(s) on Search Criteria: " & varLookFor_Original
Selection.Font.Bold = True
Range("A2").Select
'formatting printing
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$2"
End With
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.25)
.FooterMargin = Application.InchesToPoints(0.25)
.Orientation = xlLandscape
.Order = xlOverThenDown
.Zoom = 80
.LeftHeader = "&""Tms Rmn,Bold""&U&A"
.LeftFooter = "Printed: &D - &T"
.CenterFooter = "Page &P of &N"
.RightFooter = "&F-&A"
.PrintGridlines = True
End With
ActiveWindow.Zoom = 75
're-hide previously hidden sheets
On Error Resume Next
y = UBound(aryHiddensheets)
For x = 1 To y
Worksheets(aryHiddensheets(x)).Visible = False
Next
'Error Handling routines - currently not used
Exit_Err_Handler1:
Exit Sub
Err_Handler1:
MsgBox Err.Description & " - (Error # " & Err.Number & ")"
Resume Exit_Err_Handler1
End Sub
'================================================
Public Function funcErrorType(varTest As Variant) As String
Dim strAnswer As String
Select Case varTest
Case CVErr(xlErrDiv0) '2007
strAnswer = "#Div/0!"
Case CVErr(xlErrNA) '2042
strAnswer = "#N/A"
Case CVErr(xlErrName) '2029
strAnswer = "#Name?"
Case CVErr(xlErrNull) '2000
strAnswer = "#Null!"
Case CVErr(xlErrNum) '2036
strAnswer = "#Num!"
Case CVErr(xlErrRef) '2023
strAnswer = "#Ref!"
Case CVErr(xlErrValue) '2015
strAnswer = "#Value!"
Case Else
strAnswer = "Unknown"
End Select
funcErrorType = strAnswer
End Function
'================================================
