VBAサンプル集
他ブックへのリンクエラーを探し解除するマクロ

ExcelマクロVBAの実用サンプル、エクセルVBA集と解説
公開日：2013年5月以前　最終更新日：2020-08-28

他ブックへのリンクエラーを探し解除するマクロ


リンクエラーが見つけられない・・・
「リンクの編集」で、「リンクの解除」を選択してもリンクが削除できない・・・


前ページの他ブックへのリンクエラーを探し解除するでは、
リンクエラーが見つけられない… 「リンクの編集」で、「リンクの解除」を選択してもリンクが削除できない… こんな経験をした人は多いのではないでしょうか。エクセルをいろいろと操作していると、意図せずに参照先が別ブックになってしまい、かつ、その参照先のブックが無くなってしまっている… こんな場合に、リンクエラーとなります。
発生原因や外部（他ブック）リンクの探し方を解説しました、
簡単には探せないということも説明しました。

自分で必要でもあり使いたいということでマクロを作成したのですが、
公開にあたって、機能を盛り込みアプリっぽくしたものを公開します。

マクロVBAはかなり大きく、複雑になっていますので、
VBAの詳しい解説は省略しています。
書いたVBAコードは公開することを意図して、
意図的に細かいテクニックをいろいろなパターンで使っています。
VBA内のコメントを頼りにコードを読み解いていくのは、VBAの良い勉強になると思います。

シート構成と全体の流れの詳細は、
前ページの他ブックへのリンクエラーを探し解除するを参照してください。
リンクエラーが見つけられない… 「リンクの編集」で、「リンクの解除」を選択してもリンクが削除できない… こんな経験をした人は多いのではないでしょうか。エクセルをいろいろと操作していると、意図せずに参照先が別ブックになってしまい、かつ、その参照先のブックが無くなってしまっている… こんな場合に、リンクエラーとなります。
ここでは、マクロVBAの全文を掲載をします。


機能概要

「検索開始」ボタン
・指定ブックの外部（他のブックの）リンクを全て取得して一覧表示します。
　リンク切れかどうかにかかわらず、全ての外部（他のブックの）リンクを出力します。
・リンク判定として、リンク切れの場合は「×」、数式が複雑で判定困難な場合は「△」を出力します。
・削除すべきリンクについては、削除欄に「する」を出力。
「削除」ボタン
削除欄「する」のリンクを削除します。
「表示最大件数」について
外部（他のブック）リンクは、正常かエラーかにかかわらずセル毎に全て一覧に出力します。
行全体、列全体に対して（条件付き書式や入力規則が）リンク設定されている場合は膨大な数となってしまいます。
連続セルが同一設定の場合はセル範囲で出力するようにしていますが、
1行おきに交互に違う設定がしてある場合等、
セル範囲でまとめて表現できない場合に出力行数が膨大になってしまう場合があります。
そのような場合の対応として、「表示最大件数」を超えた時点で処理を終了しています。
また、リンクされている件数が多いと多大な処理時間がかかってしまうので、
最初は少ない数字にして確認したほうが良いでしょう。


シート構成

シートは、「リンクエラー検索」の一つだけです。

マクロVBA リンクエラー画像


全体の流れ

「検索開始」ボタン
↓
検索対象のブックを選択
↓
結果が5行目以降に表示されます。
↓
検索完了メッセージが表示されます。
↓
表示された一覧を確認し、E列の「する」を適切に指定してください。
↓
「削除」ボタンでE列「する」が削除されます。



以下に、VBAコードを掲載します。
結構長いVBAとなっていますので、個別の説明は省略します。
VBAコード内に適宜コメントを入れていますので、これを参考に読み解いてみてください。

標準モジュール

一旦掲載後にVBAコードを何度か大幅に変更しています。
当初掲載のVBAコードはこちら
他ブックへのリンクエラーを探し解除するマクロ（変更前）

以下は変更後のマクロVBAコードになります。
モジュール名は何でも構いません。
以下では、モジュールを3つに分けています。
・Constと共通関数
・「検索開始」ボタン
・「削除」ボタン

Option Explicit

'待機中のイベントがある時だけDoEventsがCallされる
Public Declare PtrSafe Function GetInputState Lib "USER32" () As Long

Public Const NmTargetBook As String = "nmTargetBook" '対象ブック指定のセル
Public Const NmCntMax As String = "nmCntMax" '表示最大件数のセル
Public Const StartErrRow As Long = 5　 '出力シートの開始行

'出力文字列定数
Public Const Cns数式 As String = "数式"
Public Const Cns名前定義 As String = "名前定義"
Public Const Cns条件書式 As String = "条件書式"
Public Const Cns入力規則 As String = "入力規則"
Public Const Cnsマクロ登録 As String = "マクロ登録"
Public Const Cnsバツ As String = "×"
Public Const Cns三角 As String = "△"
Public Const Cnsする As String = "する"
Public Const Cnsしない As String = "しない"
Public Const Cns削除済 As String = "削除済"

Public wb As Workbook　　　　　'検索対象ブック
Public ws As Worksheet　　　　 '検索対象シート
Public WsErr As Worksheet　　　'出力シート
Public ErrMsg As String　　　　'保存用エラーメッセージ
Public CntAll As Long　　　　　'確認するセル数
Public CntMax As Long　　　　　'表示最大件数
Public HoldAddress As String　 'セル範囲統合中のアドレス
Public CntHold As Long　　　　 'セル範囲統合中の件数

Public Enum Col '出力シートの列位置の列挙
　　種別 = 1
　　場所 = 2
　　詳細 = 3
　　判定 = 4
　　削除 = 5
End Enum

'###　Rangeオブジェクトからセルのアドレス文字を作成　###
Public Function RangeToAddress(ByVal rng As Range, _
　　　　　　　　　　　　　　　　Optional ByVal strFix As String) _
　　　　　　　　　　　　　　　　As String
　　RangeToAddress = strFix & "'" & rng.Worksheet.Name & _
　　　　　　　　　　 "'!" & rng.Address(False, False)
End Function

'###　セルのアドレス文字からRangeオブジェクトを作成　###
Public Function AddressToRange(ByVal wb As Workbook, _
　　　　　　　　　　　　　　　　ByVal sAddress As String, _
　　　　　　　　　　　　　　　　Optional ByVal i As Long = 0) _
　　　　　　　　　　　　　　　　As Range
　　Dim sSheet As String
　　Dim sRange As String
　　Dim iPos As Long
　　
　　'アドレス文字に!がない場合は処理不能
　　If InStr(sAddress, "!") = 0 Then
　　　　If i > 0 Then MsgBox "B" & i & "セルの値が不正です。"
　　　　End
　　End If
　　
　　Err.Clear '念のため呼出元でエラーが出ていた場合
　　
　　'"!"でシート名とセルアドレス文字に分割
　　iPos = InStrRev(sAddress, "!")
　　sSheet = Mid(sAddress, 2, iPos - 3)
　　sRange = Mid(sAddress, iPos + 1)
　　
　　'シート名とセルアドレス文字からRangeオブジェクト作成
　　Set AddressToRange = wb.Worksheets(sSheet).Range(sRange)
　　If Err Then
　　　　Err.Clear
　　　　If i > 0 Then MsgBox "B" & i & "セルの値が不正です。"
　　　　End
　　End If
End Function

'###　ステータスバー表示　###
Public Sub DispStatusBar(ByVal argMsg1 As String, _
　　　　　　　　　　　　　　Optional ByVal argMsg2 As String = "")
　　Static StatusMsg As String '静的変数
　　If argMsg1 <> "" Then StatusMsg = argMsg1
　　If argMsg2 <> "" Then argMsg2 = "（" & argMsg2 & "）"
　　Application.StatusBar = StatusMsg & argMsg2
　　If GetInputState() Then DoEvents
End Sub

'### 件数カウントとセル数が多いと「反応なし」になることへの対応 ###
Public Sub CountAndDoEvents()
　　CntAll = CntAll + 1
　　If GetInputState() Then DoEvents
End Sub



Option Explicit

'###　リンクエラー検索のメイン処理：「検索開始」ボタン　###
Public Sub SearchErrorLink()
　　Dim rng1 As Range
　　Dim i As Long, j As Long
　　Dim StartTime As Date
　　Dim isErr As Boolean
　　
　　Set WsErr = ActiveSheet 'リンクエラー検索
　　
　　'チェック対象ブック選択
　　With WsErr
　　　　.Unprotect 'シート保護解除
　　　　Set wb = frmSelectBook.DoModal(.Range(NmTargetBook))
　　　　If wb Is Nothing Then
　　　　　　.Protect
　　　　　　Exit Sub
　　　　End If
　　　　ThisWorkbook.Activate
　　End With
　　
　　'開始処理
　　StartTime = Now()
　　Application.Cursor = xlWait
　　CntAll = 0: HoldAddress = "": CntHold = 0
　　WsErr.Unprotect
　　isErr = True
　　
　　'エラー出力先を準備
　　With WsErr
　　　　CntMax = .Range(NmCntMax)
　　　　Set rng1 = .Cells.SpecialCells(xlCellTypeLastCell)
　　　　If rng1.Row >= StartErrRow Then
　　　　　　.Range(.Cells(StartErrRow, "A"), rng1).Clear
　　　　End If
　　　　.Range(.Columns(Col.場所), .Columns(Col.詳細)).NumberFormatLocal = "@"
　　　　.Range(.Columns(Col.場所), .Columns(Col.詳細)).WrapText = True
　　　　.Range(.Columns(Col.判定), .Columns(Col.削除)).Font.Bold = True
　　　　.Range(.Columns(Col.判定), .Columns(Col.削除)).HorizontalAlignment = xlCenter
　　　　Application.Goto .Cells(StartErrRow, Col.種別), True
　　End With
　　
　　'数式
　　If Not checkFormula(wb) Then GoTo FinalExit
　　
　　'名前定義
　　If Not checkNames(wb) Then GoTo FinalExit
　　
　　'条件付き書式
　　If Not checkFormatConditions(wb) Then GoTo FinalExit
　　
　　'入力規則
　　If Not checkValidation(wb) Then GoTo FinalExit
　　
　　'オブジェクトの登録マクロ
　　If Not checkShapes(wb) Then GoTo FinalExit
　　
　　isErr = False
　　
FinalExit: '途中でエラーがあった時の飛び先
　　If isErr Then
　　　　MsgBox "処理中で問題が発生しました。" & vbLf & _
　　　　　　　　"途中からは処理がスキップされています。" & vbLf & vbLf & _
　　　　　　　　Application.StatusBar & vbLf & _
　　　　　　　　ErrMsg & vbLf & vbLf & _
　　　　　　　　Err.Description, vbExclamation
　　End If
　　
　　'エラー出力シートを設定
　　Call setOutputSheet
　　
　　'終了処理
　　Dim CntLink As Long, CntErr As Long, CntPend As Long
　　With WsErr
　　　　CntLink = .Cells(.Rows.Count, Col.種別).End(xlUp).Row - StartErrRow + 1
　　　　CntErr = WorksheetFunction.CountIf(.Columns(Col.判定), "*" & Cnsバツ & "*")
　　　　CntPend = WorksheetFunction.CountIf(.Columns(Col.判定), "*" & Cns三角 & "*")
　　End With
　　Application.StatusBar = False
　　Application.Cursor = xlDefault
　　MsgBox "チェック完了しました。" & vbLf & vbLf & _
　　　　　　"処理時間=" & CDate(Now() - StartTime) & vbLf & vbLf & _
　　　　　　"確認セル範囲数 = " & Format(CntAll, "#,##0") & vbLf & _
　　　　　　"　外部 リンク数 = " & Format(CntLink, "#,##0") & vbLf & _
　　　　　　"　エラー リンク 数 = " & Format(CntErr, "#,##0") & vbLf & _
　　　　　　"　保留 リンク数 = " & Format(CntPend, "#,##0"), _
　　　　　　vbOKOnly, "結果表示"
End Sub

'数式
Private Function checkFormula(ByVal wb As Workbook) As Boolean
　　Dim rng1 As Range, rng2 As Range
　　On Error Resume Next
　　For Each ws In wb.Worksheets
　　　　Call DispStatusBar("数式のチェック中：" & ws.Name)
　　　　Set rng1 = ws.Cells.SpecialCells(xlCellTypeFormulas)
　　　　If Err Then
　　　　　　Err.Clear
　　　　Else
　　　　　　For Each rng2 In rng1
　　　　　　　　If setError(rng2, rng2.Formula) Then Exit Function
　　　　　　　　Call CountAndDoEvents
　　　　　　Next
　　　　End If
　　Next
　　On Error GoTo 0
　　checkFormula = True
End Function

'名前定義
Private Function checkNames(ByVal wb As Workbook) As Boolean
　　Dim nm As Name
　　On Error Resume Next
　　Call DispStatusBar("名前定義のチェック中：")
　　For Each nm In wb.Names
　　　　If setError(nm, nm.RefersTo) Then Exit Function
　　　　Call CountAndDoEvents
　　Next
　　checkNames = True
End Function
　　
'条件付き書式
Private Function checkFormatConditions(ByVal wb As Workbook) As Boolean
　　Dim i As Long
　　Dim rng1 As Range, rng2 As Range
　　Dim fcds As FormatConditions
　　Dim fcd As FormatCondition
　　Dim ws As Worksheet
　　On Error Resume Next
　　For Each ws In wb.Worksheets
　　　　Call DispStatusBar("条件付き書式のチェック中：" & ws.Name)
　　　　Set rng1 = ws.Cells.SpecialCells(xlCellTypeAllFormatConditions)
　　　　If Err Then
　　　　　　Err.Clear
　　　　Else
　　　　　　Set fcds = rng1.FormatConditions
　　　　　　For i = fcds.Count To 1 Step -1
　　　　　　　　'「数式を使用して…」のみ対象
　　　　　　　　If TypeName(fcds(i)) = "FormatCondition" Then
　　　　　　　　　　Set fcd = fcds(i)
　　　　　　　　　　'Parentからセルを取得するためコレクションを渡す
　　　　　　　　　　If setError(fcds, fcd.Formula1, i) Then Exit Function
　　　　　　　　End If
　　　　　　　　Call CountAndDoEvents
　　　　　　Next
　　　　End If
　　Next
　　checkFormatConditions = True
End Function

'入力規則
Private Function checkValidation(ByVal wb As Workbook) As Boolean
　　Dim rng1 As Range, rng2 As Range, rng3 As Range
　　Dim vdt As Validation
　　On Error Resume Next
　　For Each ws In wb.Worksheets
　　　　Call DispStatusBar("入力規則のチェック中：" & ws.Name)
　　　　Set rng1 = ws.Cells.SpecialCells(xlCellTypeAllValidation)
　　　　If Err Then
　　　　　　Err.Clear
　　　　Else
　　　　　　For Each rng2 In rng1.Areas
　　　　　　　　Set vdt = rng2.Validation
　　　　　　　　If vdt.Formula1 & vdt.Formula2 <> "" Then
　　　　　　　　　　If Err Then
　　　　　　　　　　　　Err.Clear
　　　　　　　　　　　　For Each rng3 In rng2
　　　　　　　　　　　　　　Set vdt = rng3.Validation
　　　　　　　　　　　　　　If setError(vdt, vdt.Formula1 & vdt.Formula2) Then Exit Function
　　　　　　　　　　　　　　Call CountAndDoEvents
　　　　　　　　　　　　Next
　　　　　　　　　　Else
　　　　　　　　　　　　If setError(vdt, vdt.Formula1 & vdt.Formula2) Then Exit Function
　　　　　　　　　　　　Call CountAndDoEvents
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Next
　　　　End If
　　Next
　　checkValidation = True
End Function

'オブジェクトの登録マクロ
Private Function checkShapes(ByVal wb As Workbook) As Boolean
　　Dim sp As Shape
　　For Each ws In wb.Worksheets
　　　　Call DispStatusBar("登録マクロのチェック中：" & ws.Name)
　　　　For Each sp In ws.Shapes
　　　　　　If Left(sp.Name, 9) <> "Drop Down" Then
　　　　　　　　If sp.OnAction Like "*[!]*" And _
　　　　　　　　　 InStr(sp.OnAction, wb.Name & "!") <> 1 Then
　　　　　　　　　　If setError(sp) Then Exit Function
　　　　　　　　End If
　　　　　　End If
　　　　　　Call CountAndDoEvents
　　　　Next
　　Next
　　checkShapes = True
End Function

'###　エラー出力シート作成　###
Private Sub setOutputSheet()
　　Dim i As Long, j As Long
　　ThisWorkbook.Activate
　　With WsErr
　　　　'セル範囲アドレスの出力残
　　　　j = .Cells(.Rows.Count, 1).End(xlUp).Row
　　　　If CntHold > 0 Then .Cells(j, Col.場所) = HoldAddress
　　　　
　　　　'「削除」に入力規則設定
　　　　With .Range(.Cells(StartErrRow, Col.削除), .Cells(j, Col.削除))
　　　　　　.Validation.Delete
　　　　　　.Validation.Add Type:=xlValidateList, Formula1:=Cnsする & "," & Cnsしない
　　　　　　.Interior.Color = XlRgbColor.rgbFloralWhite
　　　　　　.Locked = False
　　　　End With
　　　　
　　　　'罫線設定
　　　　.Cells(StartErrRow - 1, Col.種別).CurrentRegion.Borders.LineStyle = xlContinuous
　　　　For i = StartErrRow To j
　　　　　　If .Cells(i, Col.種別) <> .Cells(i - 1, Col.種別) Then
　　　　　　　　.Range(.Cells(i, Col.種別), .Cells(i, Col.削除)).Borders(xlEdgeTop).LineStyle _
　　　　　　　　　　= XlLineStyle.xlDouble
　　　　　　End If
　　　　Next
　　　　
　　　　'条件付き書式と入力規則は、リンク先の存否にかかわらず削除対象
　　　　For i = 5 To j
　　　　　　If .Cells(i, Col.判定) = Cnsバツ Or _
　　　　　　　　.Cells(i, Col.種別) = Cns条件書式 Or _
　　　　　　　　.Cells(i, Col.種別) = Cns入力規則 Then
　　　　　　　　If .Cells(i, Col.削除) = "" Then
　　　　　　　　　　.Cells(i, Col.削除) = Cnsする
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　　　Application.Goto .Cells(StartErrRow, Col.種別), True
　　　　.Protect 'シート保護
　　　　.Select
　　End With
End Sub

'###　見つけた他ブックのリンクに対する処理　###
Private Function setError(ByVal obj As Object, _
　　　　　　　　　　　　　Optional ByVal sLink As String = "", _
　　　　　　　　　　　　　Optional ByVal i As Integer = 0) _
　　　　　　　　　　　　　As Boolean
　　'外部リンクが無い場合はFalseで抜ける
　　If sLink <> "" And _
　　　 Not sLink Like "*[[]*[]]*[!]*" Then
　　　　Exit Function
　　End If
　　
　　Dim rng As Range, rng1 As Range, rng2 As Range
　　Dim nm As Name
　　Dim fcds As FormatConditions
　　Dim vdt As Validation
　　Dim sp As Shape
　　Dim myArray(1 To 1, Col.種別 To Col.判定)
　　Dim errRow As Long
　　
　　setError = True
　　If Err Then Exit Function '呼び出し元でエラーが出ている場合
　　
　　Select Case TypeName(obj)
　　　　Case "Range" '数式
　　　　　　Set rng = obj
　　　　　　ErrMsg = "場所：" & rng.Address(False, False)
　　　　　　Call setMyArray(myArray, _
　　　　　　　　　　　　　　Cns数式, _
　　　　　　　　　　　　　　RangeToAddress(rng, "'"), _
　　　　　　　　　　　　　　rng.Formula, _
　　　　　　　　　　　　　　isLinkExist(rng.Formula))
　　　　Case "Name" '名前定義
　　　　　　Set nm = obj
　　　　　　ErrMsg = "場所：" & nm.Name
　　　　　　Call setMyArray(myArray, _
　　　　　　　　　　　　　　Cns名前定義, _
　　　　　　　　　　　　　　nm.Name, _
　　　　　　　　　　　　　　nm.RefersTo, _
　　　　　　　　　　　　　　isLinkExist(nm.RefersTo))
　　　　Case "FormatConditions" '条件付き書式
　　　　　　Set fcds = obj
　　　　　　Set rng = fcds.Parent.Cells
　　　　　　ErrMsg = "場所：" & rng.Address(False, False)
　　　　　　Call setMyArray(myArray, _
　　　　　　　　　　　　　　Cns条件書式, _
　　　　　　　　　　　　　　RangeToAddress(rng, "'"), _
　　　　　　　　　　　　　　fcds(i).Formula1, _
　　　　　　　　　　　　　　isLinkExist(fcds(i).Formula1))
　　　　Case "Validation" '入力規則
　　　　　　Set vdt = obj
　　　　　　Set rng = vdt.Parent
　　　　　　ErrMsg = "場所：" & rng.Address(False, False)
　　　　　　If vdt.Formula2 = "" Then
　　　　　　　　Call setMyArray(myArray, _
　　　　　　　　　　　　　　Cns入力規則, _
　　　　　　　　　　　　　　RangeToAddress(rng, "'"), _
　　　　　　　　　　　　　　vdt.Formula1, _
　　　　　　　　　　　　　　isLinkExist(vdt.Formula1))
　　　　　　Else
　　　　　　　　Call setMyArray(myArray, _
　　　　　　　　　　　　　　Cns入力規則, _
　　　　　　　　　　　　　　RangeToAddress(rng, "'"), _
　　　　　　　　　　　　　　vdt.Formula1 & vbLf & vdt.Formula2, _
　　　　　　　　　　　　　　isLinkExist(vdt.Formula1) & vbLf & _
　　　　　　　　　　　　　　　　isLinkExist(vdt.Formula2))
　　　　　　End If
　　　　Case "Shape" 'オブジェクトの登録マクロ
　　　　　　Set sp = obj
　　　　　　Set rng = sp.TopLeftCell
　　　　　　ErrMsg = "場所：" & rng.Address(False, False)
　　　　　　Call setMyArray(myArray, _
　　　　　　　　　　　　　　Cnsマクロ登録, _
　　　　　　　　　　　　　　sp.Name & ":" & RangeToAddress(rng), _
　　　　　　　　　　　　　　sp.OnAction, _
　　　　　　　　　　　　　　isLinkExist2(sp.OnAction))
　　　　Case Else 'あり得ないが念のため
　　　　　　ErrMsg = TypeName(obj) & ":" & obj.Name
　　End Select
　　
　　errRow = WsErr.Cells(WsErr.Rows.Count, Col.種別).End(xlUp).Row + 1
　　　　
　　'出力セルを範囲に統合
　　If myArray(1, Col.種別) = WsErr.Cells(errRow - 1, Col.種別) And _
　　　　myArray(1, Col.詳細) = WsErr.Cells(errRow - 1, Col.詳細) Then
　　　　Select Case myArray(1, Col.種別)
　　　　　　Case Cns数式, Cns条件書式, Cns入力規則
　　　　　　　　If CntHold > 0 Then
　　　　　　　　　　Set rng1 = AddressToRange(wb, Mid(HoldAddress, 2))
　　　　　　　　Else
　　　　　　　　　　Set rng1 = AddressToRange(wb, WsErr.Cells(errRow - 1, Col.場所))
　　　　　　　　End If
　　　　　　　　Set rng2 = AddressToRange(wb, Mid(myArray(1, Col.場所), 2))
　　　　　　　　If rng1.Worksheet Is rng2.Worksheet Then
　　　　　　　　　　Set rng = Union(rng1, rng2)
　　　　　　　　　　HoldAddress = RangeToAddress(rng, "'")
　　　　　　　　　　If CntHold Mod 100 = 0 Then
　　　　　　　　　　　　Call DispStatusBar("", "同一設定の統合中：" & HoldAddress)
　　　　　　　　　　End If
　　　　　　　　　　CntHold = CntHold + 1
　　　　　　　　　　errRow = 0
　　　　　　　　End If
　　　　End Select
　　End If
　　
　　'シートに出力
　　With WsErr
　　　　If errRow > 0 Then
　　　　　　If CntHold > 0 Then
　　　　　　　　.Cells(errRow - 1, Col.場所) = HoldAddress
　　　　　　　　HoldAddress = "": CntHold = 0
　　　　　　　　Call DispStatusBar("")
　　　　　　End If
　　　　　　.Range(.Cells(errRow, Col.種別), .Cells(errRow, Col.判定)) = myArray
　　　　　　'マクロブックに切り替えて進捗が見えるように
　　　　　　ThisWorkbook.Activate
　　　　　　.Select
　　　　　　DoEvents
　　　　　　If errRow > 0 Then .Cells(errRow, Col.場所).Select
　　　　　　DoEvents
　　　　End If
　　End With
　　
　　'表示最大件数の確認
　　If errRow - StartErrRow + 1 > CntMax Then
　　　　ErrMsg = ErrMsg & vbLf & vbLf & _
　　　　　　　　"エラー最大件数件を超えました。" & vbLf & vbLf & _
　　　　　　　　"処理を終了します。"
　　　　setError = True
　　　　Exit Function
　　End If
　　
　　setError = False
End Function

'###　配列へ入れるだけ、記述の簡易化の為だけ　###
Private Sub setMyArray(ByRef myArray(), _
　　　　　　　　　　　　ByVal arg1 As String, _
　　　　　　　　　　　　ByVal arg2 As String, _
　　　　　　　　　　　　ByVal arg3 As String, _
　　　　　　　　　　　　ByVal arg4 As String)
　　myArray(1, Col.種別) = arg1
　　myArray(1, Col.場所) = arg2
　　myArray(1, Col.詳細) = arg3
　　myArray(1, Col.判定) = arg4
End Sub

'###　他ブックのリンク先のファイル存在確認　###
Private Function isLinkExist(ByVal strLink As String) As String
　　　　Dim wbWork As Workbook
　　　　Dim iPos As Integer
　　　　Dim sTemp As String
　　　　
　　　　isLinkExist = ""
　　　　
　　　　'他ブック参照なしならExit
　　　　If strLink = "" Then Exit Function
　　　　If Not strLink Like "*[[]*[]]*[!]*" Then Exit Function
　　　　
　　　　'他ブック参照が複数ある場合は判定保留
　　　　If strLink Like "*[[]*[]]*[[]*[]]*" Then
　　　　　　isLinkExist = Cns三角
　　　　　　Exit Function
　　　　End If
　　　　
　　　　'先頭の=削除、数式先頭の関数を削除
　　　　sTemp = editFormula(strLink)
　　　　
　　　　'他ブックのフルパス取得、[]と!と\で判定
　　　　sTemp = getBookFullpath(sTemp)
　　　　
　　　　'ブック名だけの場合は、開いているブックを探す
　　　　If InStr(sTemp, "\") = 0 Then
　　　　　　For Each wbWork In Workbooks
　　　　　　　　If wbWork.Name = sTemp Then
　　　　　　　　　　Exit Function
　　　　　　　　End If
　　　　　　Next
　　　　End If
　　　　
　　　　'フルパス以外はエラー
　　　　If InStr(sTemp, "\") = 0 Then
　　　　　　isLinkExist = Cnsバツ
　　　　　　Exit Function
　　　　End If
　　　　
　　　　'Dir関数でファイルの存在確認
　　　　If Dir(sTemp) = "" Then
　　　　　　If Err Then '数式が複雑なためフルパスに変換失敗
　　　　　　　　Err.Clear
　　　　　　　　isLinkExist = Cns三角
　　　　　　　　Exit Function
　　　　　　End If
　　　　　　isLinkExist = Cnsバツ
　　　　End If
End Function
'###　他ブックのリンク先のファイル存在確認：オブジェクト用　###
Private Function isLinkExist2(ByVal strLink As String) As String
　　　　Dim iPos As Integer
　　　　Dim sTemp As String
　　　　
　　　　isLinkExist2 = ""
　　　　
　　　　'他ブック参照なしならExit
　　　　If strLink = "" Then Exit Function
　　　　If InStr(strLink, "\") = 0 Then Exit Function
　　　　
　　　　'マクロの登録不正
　　　　If InStr(strLink, "!") = 0 Then
　　　　　　isLinkExist2 = Cnsバツ
　　　　　　Exit Function
　　　　End If
　　　　
　　　　'登録マクロのフルパス取得
　　　　iPos = InStrRev(strLink, "!")
　　　　sTemp = Left(strLink, iPos - 1)
　　　　If sTemp Like "'*'" Then
　　　　　　sTemp = Mid(sTemp, 2, Len(sTemp) - 2)
　　　　End If
　　　　
　　　　'Dir関数でファイルの存在確認
　　　　If Dir(sTemp) = "" Then
　　　　　　If Err Then '数式が複雑なためフルパスに変換失敗
　　　　　　　　Err.Clear
　　　　　　　　isLinkExist2 = Cns三角
　　　　　　　　Exit Function
　　　　　　End If
　　　　　　isLinkExist2 = Cnsバツ
　　　　End If
End Function

'###　先頭の=削除と、数式先頭の関数を削除　###
Private Function editFormula(ByVal aStr As String) As String
　　Dim i As Long
　　Dim iPos As Long
　　
　　'先頭の=削除
　　If Left(aStr, 1) = "=" Then aStr = Mid(aStr, 2)
　　
　　'数式先頭の関数を削除
　　iPos = 0
　　For i = 1 To Len(aStr)
　　　　If Mid(aStr, i, 1) = "(" Or _
　　　　　　Mid(aStr, i, 1) = "'" Or _
　　　　　　Mid(aStr, i, 1) = "[" Then
　　　　　　iPos = i
　　　　Else
　　　　　　If (Mid(aStr, i, 1) >= "A" And Mid(aStr, i, 1) <= "Z") Or _
　　　　　　　　(Mid(aStr, i, 1) >= "0" And Mid(aStr, i, 1) <= "9") Or _
　　　　　　　　Mid(aStr, i, 1) = "." Or _
　　　　　　　　Mid(aStr, i, 1) = "," Then
　　　　　　Else
　　　　　　　　Exit For
　　　　　　End If
　　　　End If
　　Next
　　If iPos > 0 Then
　　　　If Mid(aStr, iPos, 1) = "[" Then
　　　　　　aStr = Mid(aStr, iPos)
　　　　Else
　　　　　　aStr = Mid(aStr, iPos + 1)
　　　　End If
　　End If
　　
　　editFormula = aStr
End Function

'###　他ブックのフルパス取得、[]と!と\で判定　###
Private Function getBookFullpath(ByVal aStr As String) As String
　　Dim iPos As Long
　　If aStr Like "*[[]*[]]*" Then
　　　　aStr = Left(aStr, InStrRev(aStr, "!") - 1)
　　　　aStr = Left(aStr, InStrRev(aStr, "]") - 1)
　　　　If InStr(aStr, "\") > 0 Then
　　　　　　iPos = InStrRev(aStr, "\")
　　　　Else
　　　　　　iPos = 1
　　　　End If
　　　　iPos = InStr(iPos, aStr, "[")
　　　　aStr = Left(aStr, iPos - 1) & Mid(aStr, iPos + 1)
　　　　If Left(aStr, 1) = "'" Then aStr = Mid(aStr, 2)
　　Else
　　　　aStr = Left(aStr, InStr(aStr, "!") - 1)
　　　　If Right(aStr, 1) = "'" Then aStr = Left(aStr, Len(aStr) - 1)
　　　　If Left(aStr, 1) = "'" Then aStr = Mid(aStr, 2)
　　End If
　　
　　getBookFullpath = aStr
End Function

Option Explicit

'###　E列で削除実行のメイン処理：「削除」ボタン　###
Public Sub DeleteErrorLink()
　　Dim CntDel As Long
　　Dim cntDo As Long
　　Dim cntFail As Long
　　Dim sTemp As String
　　Dim rng As Range
　　Dim i As Long
　　
　　Set WsErr = ActiveSheet 'リンクエラー検索
　　On Error Resume Next
　　
　　'対象ブックの取得と、「検索実行」時との確認
　　sTemp = WsErr.Range(NmTargetBook).Value
　　sTemp = Mid(sTemp, InStrRev(sTemp, "\") + 1)
　　Set wb = Workbooks(sTemp)
　　If Err Then
　　　　MsgBox "対象ブックが開かれていません。" & vbLf & vbLf & _
　　　　　　　　"「検索開始」実行後に行ってください。"
　　　　Exit Sub
　　End If
　　If WsErr.Range(NmTargetBook).Value <> wb.FullName Then
　　　　MsgBox "対象ブックの保存パスが変更されています。" & vbLf & vbLf & _
　　　　　　　　"「検索開始」実行後に行ってください。"
　　　　Exit Sub
　　End If
　　
　　'実行可否の確認
　　If MsgBox("「削除」で「する」が選択されている、他ブックへのリンクを削除します。" & vbLf & vbLf & _
　　　　　　　　"元に戻すことはできません。" & vbLf & vbLf & _
　　　　　　　　"万一の場合は、実行後に「保存しない」で対応してください。" & vbLf & vbLf & _
　　　　　　　　"実行してよろしいですか。", vbYesNo, "確認") = vbNo Then
　　　　Exit Sub
　　End If
　　
　　'削除処理
　　CntDel = 0: cntDo = 0: cntFail = 0
　　With WsErr
　　　　cntDo = WorksheetFunction.CountIf(.Columns(Col.削除), Cnsする)
　　　　For i = StartErrRow To .Cells(.Rows.Count, Col.種別).End(xlUp).Row
　　　　　　If .Cells(i, Col.削除) = Cnsする Then
　　　　　　　　sTemp = .Cells(i, Col.場所)
　　　　　　　　Select Case .Cells(i, Col.種別)
　　　　　　　　　　Case Cns数式 '数式
　　　　　　　　　　　　Set rng = AddressToRange(wb, sTemp, i)
　　　　　　　　　　　　rng.ClearContents
　　　　　　　　　　　　Call setProcessCount(.Cells(i, Col.削除), cntFail, CntDel)
　　　　　　　　　　Case Cns名前定義 '名前定義
　　　　　　　　　　　　wb.Names(sTemp).Delete
　　　　　　　　　　　　Call setProcessCount(.Cells(i, Col.削除), cntFail, CntDel)
　　　　　　　　　　Case Cns条件書式 '条件付き書式
　　　　　　　　　　　　Set rng = AddressToRange(wb, sTemp, i)
　　　　　　　　　　　　rng.FormatConditions.Delete
　　　　　　　　　　　　Call setProcessCount(.Cells(i, Col.削除), cntFail, CntDel)
　　　　　　　　　　Case Cns入力規則 '入力規則
　　　　　　　　　　　　Set rng = AddressToRange(wb, sTemp, i)
　　　　　　　　　　　　rng.Validation.Delete
　　　　　　　　　　　　Call setProcessCount(.Cells(i, Col.削除), cntFail, CntDel)
　　　　　　　　　　Case Cnsマクロ登録 'オブジェクトの登録マクロ
　　　　　　　　　　　　sTemp = Mid(sTemp, InStr(sTemp, ":") + 1)
　　　　　　　　　　　　Set rng = AddressToRange(wb, sTemp, i)
　　　　　　　　　　　　sTemp = .Cells(i, Col.場所)
　　　　　　　　　　　　sTemp = Left(sTemp, InStr(sTemp, ":") - 1)
　　　　　　　　　　　　rng.Worksheet.Shapes(sTemp).OnAction = ""
　　　　　　　　　　　　Call setProcessCount(.Cells(i, Col.削除), cntFail, CntDel)
　　　　　　　　End Select
　　　　　　End If
　　　　Next
　　End With
　　
　　'終了メッセージ
　　MsgBox "削除完了しました。" & vbLf & vbLf & _
　　　　　 "削除する数=" & Format(cntDo, "#,##0") & vbLf & _
　　　　　 "削除成功数=" & Format(CntDel, "#,##0") & vbLf & _
　　　　　 "削除失敗数=" & Format(cntFail, "#,##0"), _
　　　　　 vbOKOnly, "結果表示"
End Sub

'###　エラー削除のカウント　###
Private Sub setProcessCount(ByRef rng As Range, ByRef cntFail As Long, ByRef CntDel As Long)
　　If Err Then
　　　　Err.Clear
　　　　cntFail = cntFail + 1
　　Else
　　　　rng.Value = Cns削除済
　　　　CntDel = CntDel + 1
　　End If
End Sub


ユーザーフォーム

フォームのオブジェクト名は、
「frmSelectBook」

マクロVBA リンクエラー ユーザーフォーム



Option Explicit

Private pWb As Workbook
Private pRange As Range

'標準モジュールから呼ばれるエントリーポイント
Public Function DoModal(ByVal argRng As Range) As Workbook
　　Set pRange = argRng
　　If Workbooks.Count = 1 Then
　　　　btnBrowse_Click
　　Else
　　　　Call FormInitialize
　　　　Me.Show vbModal
　　End If
　　If Not pWb Is Nothing Then
　　　　pRange = pWb.FullName
　　End If
　　Set DoModal = pWb
　　Unload Me
End Function

'「Cancel」ボタン
Private Sub btnClose_Click()
　　Set pWb = Nothing
　　Unload Me
End Sub

'「Browse」ボタン、ファイルを開くダイアログ
Private Sub btnBrowse_Click()
　　Dim FileName As Variant
　　
　　If pRange.Value = "" Then
　　　　'C2セルにファイルが指定されていない場合
　　　　FileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xls*")
　　　　If FileName = False Then
　　　　　　Exit Sub
　　　　End If
　　Else
　　　　'C2セルのファイルを初期指定する
　　　　With Application.FileDialog(msoFileDialogOpen)
　　　　　　.Filters.Clear
　　　　　　.Filters.Add "Excelファイル", "*.xls*"
　　　　　　.InitialFileName = pRange.Value
　　　　　　.AllowMultiSelect = False
　　　　　　If .Show = False Then
　　　　　　　　Exit Sub
　　　　　　End If
　　　　　　FileName = .SelectedItems(1)
　　　　End With
　　End If
　　
　　'ブックを開く
　　On Error Resume Next
　　Set pWb = Workbooks.Open(FileName:=FileName, UpdateLinks:=0)
　　'開くときにエラーがでる場合の対処
　　If Err Then
　　　　Err.Clear
　　　　MsgBox "指定のファイルはVBAで開けないエラーがあります。" & vbLf & vbLf & _
　　　　　　　　"手動でファイルを開いて確認してください。"
　　End If
　　Me.Hide
End Sub

'リストを選択して「OK」
Private Sub btSelect_Click()
　　If Me.lstBook.ListIndex < 0 Then
　　　　MsgBox "ブックが選択されていません。"
　　　　Exit Sub
　　End If
　　Set pWb = Workbooks(Me.lstBook.Text)
　　Me.Hide
End Sub

'フォームの初期設定
Private Sub FormInitialize()
　　'リストボックスに開かれているブックの一覧を表示
　　With Me.lstBook
　　　　.Clear
　　　　For Each pWb In Workbooks
　　　　　　If Not pWb Is ThisWorkbook Then
　　　　　　　　.AddItem pWb.Name
　　　　　　End If
　　　　Next
　　End With
End Sub


先にも書きましたが、VBA内のコメントを頼りにコードを読み解いてください。


VBA内で使用している主なキーワード一覧

掲載しているVBAコードから主なものを抽出しました。
全てではなく、列挙定数、VBA定数、名前付き引数等は含んでいません。
ステートメント
Declare
Call
Const
Dim
DoEvents
Enum
Exit
For Next
For Each Next
Function
If Then Else Endif
Like
Mod
On Error GoTo
On Error Resume Next
Private
Public
Set
Static
Sub
With End With

プロパティ（コレクション、オブジェクト)
Application
Borders
Cells
Columns
CurrentRegion
Err
Font
FormatCondition
FormatConditions
Interior
Name
Names
Parent
Range
Rows
Shape
Shapes
SpecialCells
ThisWorkbook
TopLeftCell
Validation
Workbook
Workbooks
Worksheet
WorksheetFunction
Worksheets

プロパティ（単一値の設定、取得）
Address
Bold
Color
Cursor
Description
Formula
Formula1
Formula2
FullName
HorizontalAlignment
LineStyle
Locked
NumberFormatLocal
OnAction
Protect
RefersTo
Row
StatusBar
Unprotect
Value
WrapText

メソッド
Activate
Clear
ClearContents
Delete
Select
Union

関数
CDate
CountIf
Dir
Format
IIf
InStr
InStrRev
Left
Len
Mid
MsgBox
Now
Right
TypeName

本サイト内で何らかの解説をしていますので、
不明なキーワードがあるときは、次のgoogleカスタム検索で検索してみてください。


掲載したマクロを組み込んだ完成版のダウンロードを用意しました。

完成ファイルのダウンロード　・・・　xlsmとzipを用意してあります。



本マクロは作成後の実際の使用実績が乏しく（リンク切れファイルが多数用意できない）、
かつ、VBAもかなり大きいので想定外のエラーが出る可能性もあります。
また、本マクロで想定している、
数式、名前定義、条件付き書式、入力規則、ボタン等の登録マクロ
これら以外に、外部（他のブック）リンクが存在する場合もありえます。
このような状況に対するご意見は、「お問い合わせ」からお知らせいただければ可能な限り対応いたします。
・お問い合わせ入力フォーム ・お問い合わせについての注意事項 ・お返事について


同じテーマ「マクロVBAサンプル集」の記事

数独（ナンプレ）を解くアルゴリズムの要点とパフォーマンスの検証№1
ナンバーリンク(パズル)を解くVBAに挑戦№1
ナンバーリンクを解くVBAのパフォーマンス改善№1
オセロを作りながらマクロVBAを学ぼう
他ブックへのリンクエラーを探し解除
Excelシートの複雑な計算式を解析するVBA
Excel将棋：マクロVBAの学習用(№1)
Excel囲碁：万波奈穂先生に捧ぐ
Excel囲碁：再起動後も続けて打てるように改造
エクセルVBAで15パズルを作ってみた
エクセル麻雀ミニゲーム


新着記事NEW ・・・新着記事一覧を見る

ブール型（Boolean）のis変数・フラグについて｜VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する｜VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次｜エクセルの神髄(2024-03-20)
VBA10大躓きポイント（初心者が躓きやすいポイント）｜VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成｜ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。｜エクセル雑感(2024-02-17)
初級脱出10問パック｜VBA練習問題(2024-01-24)
累計を求める数式あれこれ｜エクセル関数応用(2024-01-22)
複数の文字列を検索して置換するSUBSTITUTE｜エクセル入門(2024-01-03)
いくつかの数式の計算中にリソース不足になりました。｜エクセル雑感(2023-12-28)


アクセスランキング ・・・ ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.RangeとCellsの使い方｜VBA入門
4.ひらがな⇔カタカナの変換｜エクセル基本操作
5.繰り返し処理（For Next)｜VBA入門
6.変数宣言のDimとデータ型｜VBA入門
7.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
8.並べ替え（Sort）｜VBA入門
9.セルのクリア（Clear,ClearContents）｜VBA入門
10.Findメソッド（Find,FindNext,FindPrevious）｜VBA入門



このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ
同じテーマの記事
新着記事
アクセスランク


↑