はじめに

エクセルでは外部のブックリンクが存在する場合、ファイルを開く際に「セキュリティ警告リンクの自動更新が無効にされました」と表示されることがある。

もしくは、以下の画像のように、「このブックには、安全ではない可能性のある外部ソースへのリンクが1つ以上含まれています。」と表示されることもある。

外部のブックリンクを使用して、データを取得していることが分かっているのであれば、有効化・更新すればよいのだが、そのつもりがないのに、毎回、このメッセージが表示され、一体、どこに外部のブックリンクがあるのか分からず、困ってしまうことがある。
そのため、Excel VBAを使って、外部のブックリンクの設定されている場所を探す方法について考えてみたい。

ブックリンクがありそうな場所について

ブックリンクの設定されている場所を探すにあたって、まず、ブックリンクがありそうな場所を特定する必要がある。今までの経験則や、今回、あれこれ試してみた結果、以下の８項目をありそうな場所として特定した。

① セル内の数式

② 名前定義

③ 入力規則

④ 条件付き書式
A.セルの値

B.特定の文字列

C.カラースケール

D.アイコンセット

E.データバー

F.数式

⑤ 図形のセル参照

⑥ 図形のマクロ登録

⑦ グラフタイトル、グラフ軸ラベルタイトル、グラフ軸/系列範囲
A.グラフタイトル

B.グラフ軸タイトル

C.グラフ軸/系列範囲

⑧ フォームコントロールのリンクするセル/入力範囲

これ以外にもあり得るかもしれないが、今回はこの8項目を検索したいと思う。

また、テーブルやピボットテーブル、クエリといったデータ接続は「セキュリティ警告外部データ接続が無効になっています」と表示されるため除外した。

《テーブル・ピボットテーブル・クエリによるデータ接続の場合》

作成したマクロの概要

標準モジュールに、メインのプロシージャとメインプロシージャから呼び出す上記で特定した8項目を検索するプロシージャ、出力シートに出力するプロシージャを作成した。

メインプロシージャ「FindExternalLinks」
各項目を検索するプロシージャ
① セル内の数式を検索「SearchCells」
② 名前定義を検索「SearchNames」
③ 入力規則を検索「SearchValidation」
④ 条件付き書式を検索「SearchFormatConditions」
⑤ 図形・グラフ・フォームコントロールを検索
　A. ループ用プロシージャ「SearchShapes」
　B. 処理用プロシージャ「SerchShapeProcess」
　C. 入力規則のドロップダウン除外用Functionプロシージャ「DropdownChack」
出力シートに出力するプロシージャ「OutputProcess」

動作手順

《メインプロシージャ「FindExternalLinks」》

出力シートを初期化
ブックリンクの設定場所を検索したい対象のブックをリンクを更新せずに開く
非表示になっているシートがある場合、表示させる
設定されているブックリンクのフルパスを取得
取得したブックリンクのフルパスからファイル名を抜き出し、検索用リストを作成
- リンクしている外部のブックを開いている場合、セル内の数式のブックリンクの表示がフルパスではなく、ファイル名だけになるため、ファイル名のみで検索する
- ファイル名が同じで、保存フォルダが違う場合、ブックリンクの情報を1件ずつファイル名のみで検索した場合、処理が重複してしまうため、Dictionaryオブジェクトで検索用リストを作成し、ファイル名の重複を除いた
作成した検索用リストのファイル名を各項目の検索用プロシージャを呼び出して検索

《セル内の数式を検索「SearchCells」》

各シートにフィルタの絞り込みがある場合は解除、非表示セルがある場合は表示させる
各シートごとのセル内を検索
- 数式を対象に部分一致でファイル名を検索する
- ブックリンクの場合、セルには数式が入力されており、ファイル名が”[]”で囲まれるため、見つかったセルのうち、数式となっているセルで、”[”を含むセルを対象としている
見つかった場合、そのシートの最初に見つかったセルを記録
見つかった場所についての情報を出力
FindNextメソッドを使って次への検索を繰り返し、見つかったら情報を出力
最初に見つかったセルへ戻ったら終了

《名前定義を検索「SearchNames」》

非表示になっている名前定義がある場合、表示させる
対象のブックの名前定義を検索
見つかった場合、その名前定義の情報を出力

《入力規則を検索「SearchValidation」》

入力規則の設定範囲記録用リストとしてDictionaryオブジェクトを作成
「On Error Resume Next」でエラーが発生しても止まらずに先へ進むようにする
シートごとに、Specialcellsメソッドを使い、入力規則の設定のあるセルの数を変数へ入れる
- 入力規則がない場合、Specialcellsメソッドはエラーとなり、変数は0で先へ進む
変数が0ではない場合、入力規則が設定されているセルごとに処理を行う
入力規則が設定されているセルと同じ入力規則のセルをSpecialcellsメソッドを使って取得
取得した設定範囲が設定範囲記録用リストにない場合、Dictionaryオブジェクトに追加
設定範囲の先頭のセルの入力規則を変数に入れて処理
- 取得した設定範囲に結合セルがある場合、結合セルの先頭のみに入力規則が設定され、結合された他のセルには設定がなく、設定があるセルとないセルが混ざった範囲となり、設定範囲全体の入力規則を取得しようとするとエラーになるため、先頭のセルの入力規則を使って処理を行う
追加した設定範囲の入力規則にファイル名があるか確認、ある場合、入力規則の情報を出力
- 入力規則のうち、Operatorプロパティが、「～の間」、「～の間以外」の場合、Formulaプロパティに加え、Formula2プロパティも確認する

《条件付き書式を検索「SearchFormatConditions」》

条件付き書式については、確認した所、外部のブックリンクを設定できそうな種類は、以下の通りだった。

指定の値を含むセルだけを書式設定
「セルの値」、「特定の文字列」
セルの値に基づいて全てのセルを書式設定
「カラースケール」、「アイコンセット」、「データバー」
数式を使用して、書式設定するセルを決定
「数式」

種類ごとに検索する場所が違うため、種類ごとの処理を行った。

シートごとに条件付き書式を検索
セルの値、特定の文字列、数式の場合、Formulaプロパティを検索
- セルの値で、Operatorプロパティが、「～の間」、「～の間以外」の場合、Formula2プロパティも検索
カラースケールの場合、ColorscaleCriteriaオブジェクトの各ItemのValueプロパティを検索
アイコンセットの場合、IconCriteriaオブジェクトの各ItemのValueプロパティを検索
データバーの場合、MaxPoint、MinPointプロパティで取得できるConditionValueオブジェクトのValueプロパティを検索

《図形・グラフ・フォームコントロールを検索》

A. ループ用プロシージャ「SearchShapes」

Shapesオブジェクトには、グラフ・フォームコントロールも含まれる
非表示になっている図形がある場合、表示させる　
シートごとに各図形に対して、処理用プロシージャを呼び出して処理
フォームコントロールのラベル・グループボックス用のチェックシートを作成している場合、最後に削除する

B. 処理用プロシージャ「SerchShapeProcess」

グループ化された図形に対しては、ShapeオブジェクトのGroupItemsプロパティで取得できるGroupShapesオブジェクトの各Itemに対して、処理用プロシージャの再帰処理を行う
　
グラフの場合、グラフタイトル、グラフ軸タイトル、グラフ軸/系列範囲も検索する
　
フォームコントロールのラベル・グループボックスの場合、セル参照の設定がFormulaプロパティに存在しないため、別処理を行う（処理内容は下記の苦労した点に記載）　
ラベル・グループボックス・ボタンを除くフォームコントロールの場合、リンクするセルを検索、さらに、リストボックス・ドロップダウンの場合には、入力範囲も検索する
※「ドロップダウン」とは「コンボボックス」のこと。コード内ではDropdownと表記されているため、ドロップダウンと表記している。
　
図形のセル参照は、ShapeオブジェクトのDrawingObjectプロパティで取得できる各オブジェクトのFormulaプロパティを確認
図形のマクロ登録は、ShapeオブジェクトのOnActionプロパティを確認

図形によっては、Formula、OnActionプロパティが存在せず、エラーとなる場合がある。そのため、On Error Resume Nextを使い、エラーが発生しても止まらずに先へ進むようにしておく。Formula、OnActionプロパティの値を取得して変数に入れる処理で、プロパティが存在しない場合はエラーとなるが、変数は空白のまま先へ進む。そこで、変数が空白ではない(プロパティが存在しており、値が入っている)場合のみ、検索する対応とした。　

　
C. 入力規則のドロップダウン除外用Functionプロシージャ「DropdownChack」

WorksheetオブジェクトのDropDownsメソッドで取得できるDropDownsオブジェクトはフォームコントロールのドロップダウンのみであることを利用し、確認したい図形の名前がDropDownsオブジェクトの各DropDownオブジェクトの名前と一致する場合は、フォームコントロールのドロップダウンであると判断しTrueを返す

Shapesオブジェクトで処理を行うと、入力規則のドロップダウンも図形として処理されてしまい、フォームコントロールのドロップダウンと区別がつかず、エラーが発生してしまった。そのため、入力規則のドロップダウンを除外するため、フォームコントロールのドロップダウンの場合Trueを返すFunctionプロシージャ「DropdownChack」を作成した。

　
※「OutputProcess」プロシージャについての説明は割愛　

苦労した点

作成に当たって、悩んだのが、フォームコントロールの「ラベル」、「グループボックス」について、「セル参照」が設定できるにもかかわらず、「Formulaプロパティ」が存在しないという問題だった。
ローカルウィンドウをくまなく探しながら、ようやく見つけたのが、DrawingObjectsオブジェクトにおいて、そのシートに1つだけラベルもしくはグループボックスがある場合、「DrawingObjectsオブジェクト」の「LinkedCellプロパティ」が、そのラベル・グループボックスの「セル参照」の値になっていることを発見した。
そのため、フォームコントロールの「ラベル」、「グループボックス」の「セル参照」の確認については、チェック用の新規シートを作成し、該当するフォームコントロールをコピーして、新規シートに貼り付け、「DrawingObjectsオブジェクト」の「LinkedCellプロパティ」を確認し、その後、作成したシートを削除する処理とした。

完成したマクロ

前提として、ブックリンクの設定されている場所を検索したいファイルのフルパスが、「設定」シートのB2セルに入力されており、検索結果は「出力」シートに出力する仕様とする。

《設定シート》

《出力シート》

作成モジュール

Private TargetBook As Workbook
Private TargetFileName As String
Private OutputSheet As Worksheet
Private ChackSheet As Worksheet

Public Sub FindExternalLinks()

Dim i As Long
Dim myLinkSources As Variant
Dim Fso  As Object
Dim myDic As Object

    Application.ScreenUpdating = False
    
    Set OutputSheet = ThisWorkbook.Sheets("出力")
    OutputSheet.Range("A1").CurrentRegion.Offset(1).ClearContents
    
    Set TargetBook = Workbooks.Open(Filename:=ThisWorkbook.Sheets("設定").Range("B2").Value, UpdateLinks:=False)
    
    For i = 1 To TargetBook.Worksheets.Count
        TargetBook.Worksheets(i).Visible = xlSheetVisible
    Next i

    'ブックリンク情報の取得
    myLinkSources = TargetBook.LinkSources
    
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set myDic = CreateObject("Scripting.Dictionary")
    
    For i = 1 To UBound(myLinkSources)
        If Not myDic.Exists(Fso.GetFileName(myLinkSources(i))) Then
            myDic.Add Fso.GetFileName(myLinkSources(i)), Fso.GetFileName(myLinkSources(i))
        End If
    Next i
    
    Set Fso = Nothing
    
    For i = 0 To myDic.Count - 1
        TargetFileName = myDic.Items()(i)
        Call SearchCells
        Call SearchNames
        Call SearchValidation
        Call SearchFormatConditions
        Call SearchShapes
    Next i
    
    ThisWorkbook.Activate
    OutputSheet.Activate
    
    Application.Goto Reference:=OutputSheet.Range("A1"), Scroll:=True
    Application.ScreenUpdating = True
    
    MsgBox "外部のブックリンク検索が完了しました。"
  
End Sub

Private Sub SearchCells()
    
Dim FindRange As Range
Dim mySheet As Worksheet
Dim StartFindRange As Range
    
    For Each mySheet In TargetBook.Worksheets
        
        If mySheet.FilterMode Then ActiveSheet.ShowAllData
        mySheet.Cells.EntireRow.Hidden = False
        mySheet.Cells.EntireColumn.Hidden = False
        
        Set FindRange = mySheet.Cells.Find(TargetFileName, LookIn:=xlFormulas, Lookat:=xlPart)
        If Not FindRange Is Nothing Then
            Set StartFindRange = FindRange    
            If FindRange.HasFormula = True And InStr(FindRange.Formula, "[") > 0 Then
                Call OutputProcess(mySheet.Name, "セル", FindRange.Address, "'" & FindRange.Formula)
            End If
            
            '次の検索
            Do
                Set FindRange = mySheet.Cells.FindNext(FindRange)
                '最初に見つかったセルに戻ったら終了
                If StartFindRange.Address = FindRange.Address Then Exit Do

                If FindRange.HasFormula And InStr(FindRange.Formula, "[") > 0 Then
                     Call OutputProcess(mySheet.Name, "セル", FindRange.Address, "'" & FindRange.Formula)
                 End If
            Loop  
        End If
    Next mySheet
 
End Sub

Private Sub SearchNames()

Dim TargetRow As Long
Dim MyName As Name
Dim i As Long

    For i = 1 To TargetBook.Names.Count
        TargetBook.Names.Item(i).Visible = True
    Next i

    For Each MyName In TargetBook.Names
        If MyName.Value Like "*" & TargetFileName & "*" Then
             Call OutputProcess("―", "名前定義", MyName.Name, "'" & MyName.Value)
        End If
    Next MyName     
End Sub

Private Sub SearchValidation()

Dim mySheet As Worksheet
Dim myRange As Range
Dim mySameRange As Range
Dim myValidation As Validation
Dim iCount As Long
Dim myDic As Object

   Set myDic = CreateObject("Scripting.Dictionary")
   
   On Error Resume Next
          
   For Each mySheet In TargetBook.Worksheets   
        iCount = 0
        'エラーの場合（＝入力規則が存在しない）　値は0のままで次へ
        iCount = mySheet.Cells.SpecialCells(xlCellTypeAllValidation).Count
        
        If iCount <> 0 Then
            '対象セルごと
            For Each myRange In mySheet.Cells.SpecialCells(xlCellTypeAllValidation)
                '同じ入力規則が設定されているセルをまとめる
                Set mySameRange = myRange.SpecialCells(xlCellTypeSameValidation)
                If Not myDic.Exists(mySameRange.Address) Then
                    myDic.Add mySameRange.Address, mySameRange.Address
                    Set myValidation = mySameRange.Cells(1).Validation
                    If myValidation.Formula1 Like "*" & TargetFileName & "*" Then
                        Call OutputProcess(mySheet.Name, "入力規則", mySameRange.Address, "'" & myValidation.Formula1)
                    ElseIf myValidation.Operator = xlBetween Or myValidation.Operator = xlNotBetween Then
                        If myValidation.Formula2 Like "*" & TargetFileName & "*" Then
                            Call OutputProcess(mySheet.Name, "入力規則", mySameRange.Address, "'" & myValidation.Formula2)
                        End If
                    End If
                End If 
            Next myRange
        End If    
    Next mySheet
    
    On Error GoTo 0
    
End Sub

Private Sub SearchFormatConditions()

Dim mySheet As Worksheet
Dim myFormatCondition As Object
Dim TargetObj As Object

    For Each mySheet In TargetBook.Worksheets
        For Each myFormatCondition In mySheet.Cells.FormatConditions               
            Select Case myFormatCondition.Type
                Case xlCellValue, xlTextString, xlExpression
                    If myFormatCondition.Formula1 Like "*" & TargetFileName & "*" Then
                        Call OutputProcess(mySheet.Name, "条件付き書式", myFormatCondition.AppliesTo.Address, "'" & myFormatCondition.Formula1)
                    ElseIf myFormatCondition.Type = xlCellValue Then
                        If myFormatCondition.Operator = xlBetween Or myFormatCondition.Operator = xlNotBetween Then
                            If myFormatCondition.Formula2 Like "*" & TargetFileName & "*" Then
                                Call OutputProcess(mySheet.Name, "条件付き書式", myFormatCondition.AppliesTo.Address, "'" & myFormatCondition.Formula2)
                            End If
                        End If
                    End If
                Case xlColorScale
                    For Each TargetObj In myFormatCondition.ColorScaleCriteria
                        If TargetObj.Value Like "*" & TargetFileName & "*" Then
                            Call OutputProcess(mySheet.Name, "条件付き書式", myFormatCondition.AppliesTo.Address, "'" & TargetObj.Value)
                            Exit For 
                        End If
                    Next TargetObj
                Case xlIconSets
                    For Each TargetObj In myFormatCondition.IconCriteria
                       If TargetObj.Value Like "*" & TargetFileName & "*" Then
                            Call OutputProcess(mySheet.Name, "条件付き書式", myFormatCondition.AppliesTo.Address, "'" & TargetObj.Value)
                            Exit For    
                        End If
                    Next TargetObj
                Case xlDatabar
                    If myFormatCondition.MaxPoint.Value Like "*" & TargetFileName & "*" Then
                        Call OutputProcess(mySheet.Name, "条件付き書式", myFormatCondition.AppliesTo.Address, "'" & myFormatCondition.MaxPoint.Value)
                    ElseIf myFormatCondition.MinPoint.Value Like "*" & TargetFileName & "*" Then
                        Call OutputProcess(mySheet.Name, "条件付き書式", myFormatCondition.AppliesTo.Address, "'" & myFormatCondition.MaxPoint.Value)
                    End If
            End Select
        Next myFormatCondition
    Next mySheet

End Sub

Private Sub SearchShapes()

Dim mySheet As Worksheet
Dim myShape As Shape
Dim TargetRow As Long
 
    For Each mySheet In TargetBook.Worksheets
        For Each myShape In mySheet.Shapes
            If myShape.Visible = msoFalse Then myShape.Visible = msoCTrue
            Call SerchShapeProcess(mySheet, myShape)
        Next myShape
    Next mySheet

    'チェック用シートを作成している場合、削除
    If Not ChackSheet Is Nothing Then
        Application.DisplayAlerts = False            
        ChackSheet.Delete
        Application.DisplayAlerts = True
    End If
    
End Sub

Private Sub SerchShapeProcess(mySheet As Worksheet, myShape As Shape)

Dim myShapeTypeName As String
Dim myGroupShape As Shape
Dim TargetAxis As Object
Dim AxisName As String
Dim mySeries As Series
Dim ChackFormulaString As String
Dim ChackOnActionString As String

    myShapeTypeName = "図形"
    
    Select Case myShape.Type 
        Case msoGroup
            For Each myGroupShape In myShape.GroupItems
                If myGroupShape.Visible = msoFalse Then myGroupShape.Visible = msoCTrue
                Call SerchShapeProcess(mySheet, myGroupShape)
            Next myGroupShape
        Case msoChart
            myShapeTypeName = "グラフ"
            If myShape.Chart.HasTitle Then
                If myShape.Chart.ChartTitle.Formula Like "*" & TargetFileName & "*" Then    
                    Call OutputProcess(mySheet.Name, "グラフタイトル", myShape.Name, "'" & myShape.Chart.ChartTitle.Formula)
                End If
            End If

            For Each TargetAxis In myShape.Chart.Axes
                If TargetAxis.HasTitle Then
                    If TargetAxis.AxisTitle.Formula Like "*" & TargetFileName & "*" Then
                         Select Case TargetAxis.Type
                            Case xlValue
                                AxisName = "グラフ数値軸タイトル"
                            Case xlCategory
                                AxisName = "グラフ項目軸タイトル"
                            Case Else
                                AxisName = "グラフ軸タイトル"
                         End Select
                         Call OutputProcess(mySheet.Name, AxisName, myShape.Name, "'" & TargetAxis.AxisTitle.Formula)
                    End If
                End If
            Next TargetAxis

            For Each mySeries In myShape.Chart.FullSeriesCollection
                If mySeries.Formula Like "*" & TargetFileName & "*" Then
                    Call OutputProcess(mySheet.Name, "グラフ系列範囲 / " & mySeries.Name, myShape.Name, "'" & mySeries.Formula)
                End If
            Next mySeries
        Case msoFormControl
            
            '入力規則のドロップダウンの確認
            If myShape.FormControlType = xlDropDown Then
                If Not DropDownChack(mySheet, myShape) Then Exit Sub
            End If
            
            myShapeTypeName = "フォームコントロール"
            Select Case myShape.FormControlType
                Case xlLabel, xlGroupBox
                     If ChackSheet Is Nothing Then Set ChackSheet = TargetBook.Sheets.Add
                     myShape.Copy
                     Application.Wait Now() + TimeSerial(0, 0, 1)  
                     ChackSheet.Paste
                     If ChackSheet.DrawingObjects.LinkedCell Like "*" & TargetFileName & "*" Then         
                         Call OutputProcess(mySheet.Name, "フォームコントロール / セル参照", myShape.Name, "'" & ChackSheet.DrawingObjects.LinkedCell)   
                     End If
                     ChackSheet.Shapes(1).Delete
                Case Is <> xlButtonControl    
                    If myShape.DrawingObject.LinkedCell Like "*" & TargetFileName & "*" Then 
                        Call OutputProcess(mySheet.Name, "フォームコントロール / リンクするセル", myShape.Name, "'" & myShape.DrawingObject.LinkedCell)
                    End If

                    If myShape.FormControlType = xlListBox Or myShape.FormControlType = xlDropDown Then
                        If myShape.DrawingObject.ListFillRange Like "*" & TargetFileName & "*" Then
                            Call OutputProcess(mySheet.Name, "フォームコントロール / 入力範囲", myShape.Name, "'" & "'" & myShape.DrawingObject.ListFillRange)
                        End If
                    End If
            End Select
    End Select
     
    If myShape.Type <> msoGroup Then
        On Error Resume Next
        'Formulaプロパティがない場合、エラーで空白のまま次へ
        ChackFormulaString = myShape.DrawingObject.Formula
        If ChackFormulaString <> "" Then
            If myShape.DrawingObject.Formula Like "*" & TargetFileName & "*" Then
                Call OutputProcess(mySheet.Name, myShapeTypeName & " / セル参照", myShape.Name, "'" & "'" & myShape.DrawingObject.Formula)
            End If
        End If
   
        'OnActionプロパティがない場合、エラーで空白のまま次へ
        ChackOnActionString = myShape.OnAction 
        If ChackOnActionString <> "" Then
            If myShape.OnAction Like "*" & TargetFileName & "*" Then
                Call OutputProcess(mySheet.Name, myShapeTypeName & " / マクロ登録", myShape.Name, "'" & "'" & myShape.OnAction)
            End If
        End If
    End If
    
    On Error GoTo 0
  
End Sub


'入力規則のドロップダウン除外用
Private Function DropDownChack(mySheet As Worksheet, myShape As Shape) As Boolean

Dim myDropDown As DropDown

    DropDownChack = False
    
    For Each myDropDown In mySheet.DropDowns
        If myDropDown.Name = myShape.Name Then DropDownChack = True: Exit For
    Next myDropDown

End Function

Private Sub OutputProcess(FindSheetName As String, FindTypeName As String, FindPlaceName As String, FindDetail As String)

Dim TargetRow As Long

    TargetRow = OutputSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
    OutputSheet.Cells(TargetRow, "A").Value = TargetFileName
    OutputSheet.Cells(TargetRow, "B").Value = FindSheetName
    OutputSheet.Cells(TargetRow, "C").Value = FindTypeName
    OutputSheet.Cells(TargetRow, "D").Value = FindPlaceName
    OutputSheet.Cells(TargetRow, "E").Value = FindDetail

End Sub

サンプルファイル保存先：