Excel VBA 消せない外部リンクの削除をサポートするツール

Option Explicit
Dim cnt As Long     '再起処理に使用するため
Dim str1 As String  '検索文字列（3列目見出し）
Dim str2 As String  '検索文字列（4列目見出し）

'ここからスタート（フォルダー指定）
Sub FolderSet()
    Dim myPath As String
    Dim tgFolder As String
    Dim lrow As Long
 
    myPath = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "対象フォルダー選択"
        .InitialFileName = myPath
        If .Show = True Then
            tgFolder = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    cnt = 1 '初期化(見出し分）
    '見出しを除きデータをクリアする
    lrow = Cells(Rows.Count, 1).End(xlUp).row
    If lrow > 1 Then Range(Cells(2, 1), Cells(lrow, 4)).ClearContents
    str1 = Cells(1, 3).Value    '検索文字列（3列目見出し）
    str2 = Cells(1, 4).Value    '検索文字列（4列目見出し）
    If str1 = "" Or str2 = "" Then
        MsgBox "C1,D1セルに検索文字列を設定してから再度実行してください！"
        Exit Sub
    End If
    
    '「再帰処理」に移す
    Call RecursiveCall(tgFolder)
    
    MsgBox "ファイル内のテキスト検索処理を終了しました！"
    
End Sub

'サブフォルダ内も含めてファイルを調べる（再帰処理）
Sub RecursiveCall(sPath As String)
    Dim buf As String
    Dim f As Object
    
    buf = Dir(sPath & "\*.*")
    Do While buf <> ""
        cnt = cnt + 1
        Cells(cnt, 1) = sPath   'フォルダー
        Cells(cnt, 2) = buf     'ファイル
        'ファイル内文字列検索処理呼び出し
        Call FileStrSearch(sPath & "\" & buf)
        buf = Dir()             '次のファイル
    Loop
    '再帰処理
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(sPath).SubFolders
            Call RecursiveCall(f.Path)  '再帰
        Next f
    End With
End Sub

'データ内のリファレンスエラー文字「#REF!」を調べる
Sub FileStrSearch(sFilePath As String)
    Dim tgf As String
    Dim sAll As String
    Dim filenum As Long
    Dim col As Long
    Dim t As Long
    Dim n As Long
    Dim chkStr As String
    
On Error GoTo ErrorHandler
    tgf = sFilePath
    'UTF-8対応のためADO(ActiveX Data Objects)を使う
    Const ReadBytes = 131072 'As Long = 128000
    Dim sText As String
    With CreateObject("ADODB.Stream")
        '（規定値）Type = adTypeText
        '（規定値）Mode = adModeRead
        .Charset = "UTF-8"
        .Open               'Streamオブジェクトを開く
        .LoadFromFile tgf   'ファイルをStreamに読込
        .Position = 0

        Do While Not .EOS
            '指定文字数を読み込んで書き込む
            sAll = sAll & .ReadText(ReadBytes)
            DoEvents
        Loop
        .Close              '閉じる
    End With
    '２列分調べるためのループ処理
    For col = 3 To 4
        If col = 3 Then
            chkStr = str1
        Else: chkStr = str2
        End If
        '検索文字列の指定がない場合は抜ける
        If chkStr = "" Then Exit For
        'データ内の文字列を調査（初回）
        t = InStr(sAll, chkStr)   'tは検索HIT位置
        If t > 0 Then n = n + 1
        '初回HIT以降を繰り返し調べる
        Do While t > 0
            t = InStr(t + 1, sAll, chkStr)
            If t > 0 Then n = n + 1
        Loop
        '調べた結果をセルに書き込む
        Cells(cnt, col) = n
        n = 0 '書き込んだら初期化する
    Next col   
    Exit Sub
ErrorHandler:
    If Err.Number = -2147024809 Then
        MsgBox "Error " & Err.Number & ": " & Err.Description & vbCrLf & _
        "[" & tgf & "]" & vbCrLf & _
        "はバイナリファイルのために発生したと思われます。" & vbCrLf & _
        "このまま処理を継続します!", _
        vbOKOnly + vbCritical, "ADODB.Stream Error"
        Resume 0
    Else
        MsgBox "Error " & Err.Number & ": " & Err.Description & vbCrLf & _
        "[" & tgf & "]" & vbCrLf & _
        "の処理中に発生したエラーです!" & vbCrLf & _
        "処理を中止します!", _
        vbOKOnly + vbCritical, "ADODB.Stream Error"
        End
    End If
End Sub