Excelの外部リンクをVBAで一括解除する【実務で活用できる】

'更新日時書き換え（Shellオブジェクトを使う）
Sub Set_ModifyDate(strfld As Variant, fn As Variant, d As Date)
    Dim objShell As Object
    Dim objFld As Object
    Dim objFile As Object
        
    '閉じたファイルの更新日時を戻す処理
    Set objShell = CreateObject("Shell.Application") 'インスタンス化
    Set objFld = objShell.Namespace(strfld) 'フォルダを取得
    Set objFile = objFld.ParseName(fn) 'ファイルを取得
    '更新日時を元に戻す
    objFile.ModifyDate = d
    'オブジェクト解放
    Set objFile = Nothing
    Set objFld = Nothing
    Set objShell = Nothing
End Sub

Option Explicit
Private Declare Function GetInputState Lib "USER32" () As Long 'DoEventsの代わり
'ブックに存在する外部リンクを設定に従い処理
Sub AdjustLinkSources()
    Dim vFileName As Variant
    Dim strfld As Variant
    'フォルダとファイル名、結果を消去
    Cells(2, 1) = ""
    Range(Cells(4, 1), Cells(4, 4).End(xlDown)) = ""
    '「ファイルを開く」ダイアログの表示
    vFileName = Application.GetOpenFilename( _
                FileFilter:="Excelワークブック,*.xls?", _
                Title:="ファイルを指定して下さい", _
                MultiSelect:=True)
    If IsArray(vFileName) = False Then _
                MsgBox ("未選択のため処理を中止します！"): Exit Sub
    
    Dim f As Variant    'ファイル用
    Dim fn As Variant   'ファイル名保存用
    Dim d As Date       '更新日時保存用
    Dim n As Long, i As Long 'カウンター用
    'チラつきをなくすためExcelインスタンスで対応
    Dim tgwb As Object
    Dim owb As Excel.Workbooks
    Dim oxl As Excel.Application
    Dim fso As Object   'ファイルシステムオブジェクト
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim vLinks As Variant   'リンクソース保存用
    Dim L As Long, B As Long    '処理数カウンター
    Dim x As Long, cnt As Long  'カウンター用
    Dim strLinkName As String
    
    On Error GoTo Err_Link
    n = 4  '4行目から開始なのでカウンター初期化
    For Each f In vFileName 'フォルダ内のファイルを取得
        If n = 4 Then       '最初のファイルでフォルダ取得
            strfld = Left(f, InStrRev(f, "\")) 'フォルダPath
            Cells(2, 1) = strfld
        End If
        fn = fso.GetFilename(f) 'ファイル名セット
        Cells(n, 1) = fn
        d = fso.GetFile(f).DateLastModified '更新日時を保存
        Set oxl = CreateObject("Excel.Application") 'インスタンス
        Set owb = oxl.Application.Workbooks 'WBオブジェクト
        If GetInputState() Then DoEvents    '重いファイル用対策
        'ブックを開く
        Set tgwb = owb.Open(Filename:=f, UpdateLinks:=0)
        'ここから開いたブックに対する処理
        With tgwb
            L = 0: B = 0    '処理数初期化
            For x = 1 To 2  '1=xlExcelLinks、2=xlOLELinks
                'リンクがあるか調べる
                If x = 1 Then
                    vLinks = .LinkSources(xlExcelLinks) 'EXCEL
                Else
                    If Cells(2, 2) <> 1 Then Exit For
                    vLinks = .LinkSources(xlOLELinks) 'OLE
                End If
                'LinkSourceが無い場合抜ける
                If Not IsArray(vLinks) Then Exit For
                cnt = UBound(vLinks)
                Cells(n, 2) = cnt
                'エラー時に処理を継続させるため
                On Error Resume Next
                For i = 1 To cnt
                    strLinkName = vLinks(i)
                    If Cells(2, 3) = 1 Then
                        'リンク先を自ブックに変更
                        .ChangeLink Name:=strLinkName, _
                                    NewName:=.FullName 'Typeは省略可能
                        If Err.Number = 0 Then
                            L = L + 1
                            GoTo pass  '成功したのでBreakLinkはパスする
                        Else: Err.Clear
                        End If
                    End If
                    If Cells(2, 4) = 1 Then
                        'リンク解除して値に変更
                        If x = 1 Then
                            .BreakLink Name:=strLinkName, _
                                    Type:=xlLinkTypeExcelLinks 'Typeは必須
                        Else: .BreakLink Name:=strLinkName, _
                                    Type:=xlLinkTypeOLELinks 'OLEType用
                        End If
                        If Err.Number = 0 Then B = B + 1
                        Err.Clear
                    End If
pass:
                Next i
                On Error GoTo Err_Link
            Next x
            'セルに処理結果を書き込む
            Cells(n, 3) = L: Cells(n, 4) = B
        End With
        If GetInputState() Then DoEvents 'DoEvents
        'ファイル保存して閉じる
        tgwb.Close (True)
        'オブジェクト初期化
        Set tgwb = Nothing
        Set owb = Nothing
        Set oxl = Nothing
        n = n + 1   'インクリメント
        'ここから更新日時を戻す処理（不要の場合はパス）
        If Cells(2, 5) = 1 Then Call Set_ModifyDate(strfld, fn, d)
    Next
    Set fso = Nothing
    If Cells(4, 1) <> "" Then MsgBox ("リンク修正・解除処理が終了しました！")
    Exit Sub
Err_Link:
     MsgBox Err.Description
    On Error Resume Next
    Open tgwb For Append As #1
    Close #1
    If Err.Number > 0 Then tgwb.Close (True) '開いていたら閉じる
    Set tgwb = Nothing
    Set owb = Nothing
    Set oxl = Nothing
    Set fso = Nothing
End Sub