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

ExcelマクロVBAの実用サンプル、エクセルVBA集と解説
最終更新日:2019-03-19

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


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


前ページの他ブックへのリンクエラーを探し解除するでは、
発生原因や外部(他ブック)リンクの探し方を解説しました、
簡単には探せないということも説明しました。

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


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

シート構成と全体の流れの詳細は、
前ページの他ブックへのリンクエラーを探し解除するを参照してください。
ここでは、マクロVBAの全文を掲載をします。


機能概要

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


シート構成

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

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


全体の流れ

「検索開始」ボタン

検索対象のブックを選択

結果が5行目以降に表示されます。

検索完了メッセージが表示されます。

表示された一覧を確認し、E列の「する」を適切に指定してください。

「削除」ボタンでE列「する」が削除されます。



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

標準モジュール

一旦掲載後にVBAコードを大幅に変更しています。
変更前のコートはこちら

モジュール名は何でも構いません。

Option Explicit

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

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

'変数
Private wb As Workbook     '検索対象ブック
Private ws As Worksheet     '検索対象シート
Private WsErr As Worksheet   '出力シート
Private ErrMsg As String    '保存用エラーメッセージ
Private CntAll As Long     '確認するセル数
Private CntLink As Long     '外部リンク数
Private CntErr As Long     'リンクエラー数
Private CntPend As Long     '保留リンク数
Private CntDel As Long     '削除数
Private CntMax As Long     '表示最大件数
Private HoldAddress As String  'セル範囲統合中のアドレス
Private CntHold As Long     'セル範囲統合中の件数

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

'### リンクエラー検索のメイン処理 ###
Public Sub SearchErrorLink()
  Dim rng1 As Range
  Dim i As Long, j As Long
  Dim StartTime As Date
  
  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: CntLink = 0: CntErr = 0: CntPend = 0: CntDel = 0
  HoldAddress = "": CntHold = 0
  WsErr.Unprotect
  j = 0
'  On Error Resume Next
  
  'エラー出力先を準備
  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 checFormula(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
  
  j = -1
FinalExit: '途中でエラーがあった時の飛び先
  If j = 0 Then
    MsgBox "処理中で問題が発生しました。" & vbLf & _
        "途中からは処理がスキップされています。" & vbLf & vbLf & _
        Application.StatusBar & vbLf & _
        ErrMsg & vbLf & vbLf & _
        Err.Description, vbExclamation
  End If
  'エラー出力シートを設定
  ThisWorkbook.Activate
  With WsErr
    .Select
    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 'シート保護
  End With
  
  '終了処理
  On Error GoTo 0
  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 checFormula(ByVal wb As Workbook) As Boolean
  Dim rng1 As Range
  Dim 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 rng2.Formula Like "*[[]*[]]*[!]*" Then
          If setError(rng2) Then Exit Function
        End If
        Call EventForEachCount
      Next
    End If
  Next
  On Error GoTo 0
  checFormula = True
End Function

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

'入力規則
Private Function checkValidation(ByVal wb As Workbook) As Boolean
  Dim rng1 As Range
  Dim rng2 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
        Set vdt = rng2.Validation
        If vdt.Formula1 & vdt.Formula2 Like "*[[]*[]]*[!]*" Then
          If setError(vdt) Then Exit Function
        End If
        Call EventForEachCount
      Next
    End If
  Next
  checkValidation = True
End Function

'オブジェクトの登録マクロ
Private Function checkShapes(ByVal wb As Workbook) As Boolean
  Dim sp As Shape
  Dim sTemp As String
  For Each ws In wb.Worksheets
    Call DispStatusBar("登録マクロのチェック中:" & ws.Name)
    DoEvents
    For Each sp In ws.Shapes
      If Left(sp.Name, 9) <> "Drop Down" Then
        sTemp = sp.OnAction
        If Err Then
          Err.Clear
          wb.Activate
          ws.Select
          sTemp = sp.OnAction
          If Err Then
            Err.Clear
            sTemp = ""
          End If
          ThisWorkbook.Activate
        End If
        If sTemp Like "*[!]*" Then
          If InStr(sp.OnAction, wb.Name & "!") <> 1 Then
            If setError(sp) Then Exit Function
          End If
        End If
      End If
      Call EventForEachCount
    Next
  Next
  checkShapes = True
End Function
  
'### 見つけた他ブックのリンクに対する処理 ###
Private Function setError(ByVal obj As Object, _
             Optional ByVal i As Integer = 0) _
             As Boolean
  Dim rng As Range
  Dim rng1 As Range
  Dim 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(myArray(1, Col.詳細)))
    Case "Name" '名前定義
      Set nm = obj
      ErrMsg = "場所:" & nm.Name
      Call setMyArray(myArray, _
              Cns名前定義, _
              nm.Name, _
              nm.RefersTo, _
              isLinkExist(myArray(1, Col.詳細)))
    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(myArray(1, Col.詳細)))
    Case "Validation" '入力規則
      Set vdt = obj
      Set rng = vdt.Parent
      ErrMsg = "場所:" & rng.Address(False, False)
      Call setMyArray(myArray, _
              Cns入力規則, _
              RangeToAddress(rng, "'"), _
              vdt.Formula1 & _
                IIf(vdt.Formula2 = "", _
                "", vbLf & vdt.Formula2), _
              isLinkExist(vdt.Formula1) & _
                IIf(vdt.Formula2 = "", _
                  "", vbLf & _
                  isLinkExist(vdt.Formula2, False)))
    Case "Shape" 'オブジェクトの登録マクロ
      Set sp = obj
      Set rng = sp.TopLeftCell
      ErrMsg = "場所:" & rng.Address(False, False)
      Call setMyArray(myArray, _
              Cnsマクロ登録, _
              sp.Name & ":" & RangeToAddress(rng), _
              sp.OnAction, _
              isLinkExist(myArray(1, Col.詳細)))
    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 rng.Worksheet Is rng2.Worksheet Then
          Set rng = Union(rng1, rng2)
          HoldAddress = RangeToAddress(rng, "'")
          CntHold = CntHold + 1
          If CntHold Mod 1000 = 0 Then
            Call DispStatusBar("", _
              "同一設定のセル範囲を統合中:" & _
              HoldAddress)
            DoEvents
          End If
          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
      DoEvents
      If errRow > 0 Then .Cells(errRow, Col.場所).Select
      DoEvents
    End If
  End With
  
  CntLink = CntLink + 1
  
  '表示最大件数の確認
  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, _
               Optional ByVal ErrCntUp As Boolean = True) _
               As String
    Dim wbWork As Workbook
    Dim i As Long
    Dim iPos As Integer
    Dim sTemp As String
    
    isLinkExist = ""
    If strLink = "" Then Exit Function
    
    '他ブック参照が複数ある場合は判定保留
    If strLink Like "*[[]*[]]*[[]*[]]*" Then
      isLinkExist = Cns三角
      CntPend = CntPend + 1
      Exit Function
    End If
    
    '引数の受け取りと、先頭の=削除
    sTemp = strLink
    If Left(sTemp, 1) = "=" Then sTemp = Mid(sTemp, 2)
    
    '数式先頭の関数を削除
    iPos = 0
    For i = 1 To Len(sTemp)
      If Mid(sTemp, i, 1) = "(" Or _
        Mid(sTemp, i, 1) = "'" Or _
        Mid(sTemp, i, 1) = "[" Then
        iPos = i
      Else
        If (Mid(sTemp, i, 1) >= "A" And Mid(sTemp, i, 1) <= "Z") Or _
          (Mid(sTemp, i, 1) >= "0" And Mid(sTemp, i, 1) <= "9") Or _
          Mid(sTemp, i, 1) = "." Or _
          Mid(sTemp, i, 1) = "," Then
        Else
          Exit For
        End If
      End If
    Next
    If iPos > 0 Then
      If Mid(sTemp, iPos, 1) = "[" Then
        sTemp = Mid(sTemp, iPos)
      Else
        sTemp = Mid(sTemp, iPos + 1)
      End If
    End If
    
    '他ブックのフルパス取得、[]と!と\で判定
    If sTemp Like "*[[]*[]]*" Then
      sTemp = Left(sTemp, InStrRev(sTemp, "!") - 1)
      sTemp = Left(sTemp, InStrRev(sTemp, "]") - 1)
      If InStr(sTemp, "\") > 0 Then
        iPos = InStrRev(sTemp, "\")
      Else
        iPos = 1
      End If
      iPos = InStr(iPos, sTemp, "[")
      sTemp = Left(sTemp, iPos - 1) & Mid(sTemp, iPos + 1)
      If Left(sTemp, 1) = "'" Then sTemp = Mid(sTemp, 2)
    Else
      sTemp = Left(sTemp, InStr(sTemp, "!") - 1)
      If Right(sTemp, 1) = "'" Then sTemp = Left(sTemp, Len(sTemp) - 1)
      If Left(sTemp, 1) = "'" Then sTemp = Mid(sTemp, 2)
    End If
    
    'ブック名だけの場合は、開いているブックを探す
    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バツ
      If ErrCntUp Then CntErr = CntErr + 1
      Exit Function
    End If
    
    'Dir関数でファイルの存在確認
    If Dir(sTemp) = "" Then
      If Err Then '数式が複雑なためフルパスに変換失敗
        Err.Clear
        isLinkExist = Cns三角
        CntPend = CntPend + 1
        Exit Function
      End If
      isLinkExist = Cnsバツ
      If ErrCntUp Then CntErr = CntErr + 1
    End If
End Function

'### Rangeオブジェクトからセルのアドレス文字を作成 ###
Private 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オブジェクトを作成 ###
Private 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

'### ステータスバー表示 ###
Private 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
  DoEvents
End Sub

'### セル数が多いと「反応なし」になることへの対応 ###
Private Sub EventForEachCount()
  CntAll = CntAll + 1
  If CntAll Mod 10000 = 0 Then DoEvents
End Sub

'### E列で削除指定の実行処理 ###
Public Sub DeleteErrorLink()
  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

Private Sub CreateWebUpLoadFile()
  Dim rng1 As Range
  ThisWorkbook.Activate
  Set WsErr = ActiveSheet 'リンクエラー検索
  With WsErr
    .Unprotect
    Set rng1 = .Cells.SpecialCells(xlCellTypeLastCell)
    If rng1.Row >= StartErrRow Then
      .Range(.Cells(StartErrRow, "A"), rng1).Clear
    End If
    .Range(NmTargetBook) = ""
    .Protect
    Application.Goto .Cells(StartErrRow, Col.種別), True
  End With
  
  Dim sFile As String
  Dim sFullPath As String
  Dim sUser
  sFile = "SearchLinkError2.xlsm"
  sFullPath = ThisWorkbook.Path & "\" & sFile
  ThisWorkbook.SaveCopyAs sFullPath
  Set wb = Workbooks.Open(sFullPath)
  With wb
    .Activate
    sUser = Application.UserName
    Application.UserName = "エクセルの神髄"
    With .BuiltinDocumentProperties
      .Item("Title").Value = ""
      .Item("Subject").Value = ""
      .Item("Category").Value = ""
      .Item("Comments").Value = ""
      .Item("Author").Value = ""
      .Item("Company").Value = ""
      .Item("Manager").Value = ""
    End With
    .Save
    .Save
    Application.UserName = sUser
  End With
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定数、名前付き引数等は含んでいません。
ステートメント
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サンプル集」の記事

エクセルでファイル一覧を作成
アメブロの記事本文をVBAでバックアップする1
数独(ナンプレ)を解くVBAに挑戦1
数独(ナンプレ)を解くアルゴリズムの要点とパフォーマンスの検証1
ナンバーリンク(パズル)を解くVBAに挑戦1
ナンバーリンクを解くVBAのパフォーマンス改善1
オセロを作りながらマクロVBAを学ぼう
他ブックへのリンクエラーを探し解除
Excelシートの複雑な計算式を解析するVBA

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

VBA+SeleniumBasicで検索順位チェッカー作成|VBA技術解説(5月18日)
テーブル操作のVBAコード(ListObject)|VBA入門(5月12日)
テーブル操作の概要(ListObject)|VBA入門(5月12日)
VBAのスクレイピングを簡単楽にしてくれるSelenium|VBA技術解説(5月6日)
Excelワークシート関数一覧(2010以降)|VBAリファレンス(4月22日)
クラスとCallByNameとポリモーフィズム(多態性)|VBA技術解説(4月6日)
VBAでのタイマー処理(SetTimer,OnTime)|VBA技術解説(4月3日)
クラスとイベントとマルチプロセス並列処理|VBA技術解説(4月2日)
エクセルの日付と時刻のまとめ|エクセル関数超技(3月6日)
Excelシートの複雑な計算式を解析するVBA|VBAサンプル集(2月18日)

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

1.ひらがな⇔カタカナの変換|エクセル基本操作
2.最終行の取得(End,Rows.Count)|VBA入門
3.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
4.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
5.RangeとCellsの使い方|ExcelマクロVBA入門
6.変数とデータ型(Dim)|ExcelマクロVBA入門
7.マクロって何?VBAって何?|ExcelマクロVBA入門
8.繰り返し処理(For Next)|ExcelマクロVBA入門
9.とにかく書いて見よう(Sub,End Sub)|VBA入門
10.セルに文字を入れるとは(Range,Value)|VBA入門



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

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


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






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

    本文下部へ