Macro to find all cells which are linked to any external workbook-
Sub find_cells_linked_to_external_workbooks()
Dim extlinks
Dim j As Long, k As Long
Dim wkb As Workbook
Dim rng As Range, cl As Range
Dim links1 As String
Dim wk As Worksheet
Set wkb = Workbooks.Add
wkb.Sheets(1).Range("a1").Value = "Sheet Name"
wkb.Sheets(1).Range("b1").Value = "Cell Address"
wkb.Sheets(1).Range("c1").Value = "Formula"
wkb.Sheets(1).Range("d1").Value = "External Link"
k = 2
extlinks = ThisWorkbook.LinkSources(xlExcelLinks)
For Each wk In ThisWorkbook.Sheets
On Error Resume Next
Set rng = wk.UsedRange.SpecialCells(xlCellTypeFormulas)
If Not rng Is Nothing Then
For j = LBound(extlinks) To UBound(extlinks)
links1 = Left(extlinks(j), InStrRev(extlinks(j), "\")) & "[" & Right(extlinks(j), Len(extlinks(j)) - InStrRev(extlinks(j), "\"))
For Each cl In rng
If InStr(" " & cl.Formula, links1) > 0 Then
wkb.Sheets(1).Range("a" & k).Value = wk.Name
wkb.Sheets(1).Range("b" & k).Value = cl.Address
wkb.Sheets(1).Range("c" & k).Value = "'" & cl.Formula
wkb.Sheets(1).Range("d" & k).Value = extlinks(j)
k = k + 1
End If
Next
Next
End If
Set rng = Nothing
Next
End Sub
Sub find_cells_linked_to_external_workbooks()
Dim extlinks
Dim j As Long, k As Long
Dim wkb As Workbook
Dim rng As Range, cl As Range
Dim links1 As String
Dim wk As Worksheet
Set wkb = Workbooks.Add
wkb.Sheets(1).Range("a1").Value = "Sheet Name"
wkb.Sheets(1).Range("b1").Value = "Cell Address"
wkb.Sheets(1).Range("c1").Value = "Formula"
wkb.Sheets(1).Range("d1").Value = "External Link"
k = 2
extlinks = ThisWorkbook.LinkSources(xlExcelLinks)
For Each wk In ThisWorkbook.Sheets
On Error Resume Next
Set rng = wk.UsedRange.SpecialCells(xlCellTypeFormulas)
If Not rng Is Nothing Then
For j = LBound(extlinks) To UBound(extlinks)
links1 = Left(extlinks(j), InStrRev(extlinks(j), "\")) & "[" & Right(extlinks(j), Len(extlinks(j)) - InStrRev(extlinks(j), "\"))
For Each cl In rng
If InStr(" " & cl.Formula, links1) > 0 Then
wkb.Sheets(1).Range("a" & k).Value = wk.Name
wkb.Sheets(1).Range("b" & k).Value = cl.Address
wkb.Sheets(1).Range("c" & k).Value = "'" & cl.Formula
wkb.Sheets(1).Range("d" & k).Value = extlinks(j)
k = k + 1
End If
Next
Next
End If
Set rng = Nothing
Next
End Sub
No comments:
Post a Comment