Excel VBA 消せない入力規則外部リンクエラーの削除ツール

'データ内の<X14:DataValidation>の「#REF!」エラー数を調べる
Sub DataValidationSearch(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 DVcount As Long
    
On Error GoTo ErrorHandler
    tgf = sFilePath
    'UTF-8対応のためADO(ActiveX Data Objects)を使う
    Const ReadBytes = 131072 '分割サイズ指定
    
    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              'Streamを閉じる
    End With
    Dim t2 As Long
    Dim tn As Long
    '２列分調べるためのループ処理
    For col = 3 To 4
        If col = 3 Then
            'データ内の文字列を調査（初回）tは検索HIT位置
            t = InStr(sAll, "<x14:dataValidations count=")
            sText = Mid(sAll, t + 28, 5)
            DVcount = Val(sText) '文字列内の数値取得
            '調べた結果をセルに書き込む
            Cells(cnt, col) = DVcount '定義数を書き込む（C列）
            '定義の終了位置取得
            tn = InStrRev(sAll, "</x14:dataValidations>")
        Else
            '個別定義の開始位置取得
            t = InStr(sAll, "<x14:dataValidation ")
            '取得出来たらカウントする
            If t > 0 Then n = n + 1
            '初回HIT以降を繰り返し調べる
            Do While t > 0
                t = InStr(t + 1, sAll, "<x14:dataValidation ")
                If t > 0 Then n = n + 1
            Loop
            '調べた結果をセルに書き込む（D列）
            Cells(cnt, col) = n
            n = 0   '変数 n 再利用のため初期化
            '次に"!#REF!"の数を調べる
            t2 = InStr(sAll, "!#REF!") 't2 は検索HIT位置
            '定義内にあるエラーならカウントする
            If t2 > 0 And t2 < tn Then n = n + 1
            '初回HIT以降を繰り返し調べる
            Do While t2 > 0
                t2 = InStr(t2 + 1, sAll, "!#REF!")
                '定義内にあるエラーならカウントする
                If t2 > 0 And t2 < tn Then n = n + 1
            Loop
            '調べた結果をセルに書き込む（E列）
            Cells(cnt, col + 1) = n
        End If
    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

'削除はここからスタート（セル選択指定）
Sub FilePathSet()
    Dim myPath As String
    Dim tgRow As Long
    Dim tgFilePath As String
    Dim res As Long
    Dim lrow As Long

    'アクティブセルの位置（行）取得
    tgRow = ActiveCell.Row
    'フルパスのファイル名取得
    tgFilePath = Cells(tgRow, 1) & "\" & Cells(tgRow, 2)
    If Dir(tgFilePath) = "" Then
        res = MsgBox("ファイルを指定しますか？", vbOKCancel)
        If res = vbOK Then
            myPath = ThisWorkbook.Path
            With Application.FileDialog(msoFileDialogFilePicker)
                .Title = "対象ファイル選択"
                .InitialFileName = myPath
                If .Show = True Then
                    tgFilePath = .SelectedItems(1)
                Else
                    Exit Sub
                End If
            End With
        Else: Exit Sub
        End If
    End If
    '見出しを除きシートの書き出し範囲をクリアする
    lrow = Cells(Rows.count, 12).End(xlUp).Row
    If lrow > 1 Then Range(Cells(2, 11), Cells(lrow, 12)).ClearContents
    '削除処理呼び出し
    Call ReplaceStrFile(tgFilePath)
End Sub

'データ内文字列の置換処理
Sub ReplaceStrFile(sFilePath As String)
    Dim tgf As String
    Dim sAll As String
    Dim sAllr As String
    Dim s As Long, t As Long, n As Long
    Dim con As Long
    Dim DVcount As Long
    Dim tREF As Long
    Dim ts As Long, tn As Long
    Dim RepStr As String
    Dim rText As String, sText As String
    
On Error GoTo ErrorHandler
    tgf = sFilePath
    'UTF-8対応のためADO(ActiveX Data Objects)を使う
    Const ReadBytes = 131072
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open               'Streamオブジェクトを開く
        .LoadFromFile tgf   'ファイルをStreamに読込
        .Position = 0
        Do While Not .EOS
            '指定文字数分を読み込んで書き込む
            sAll = sAll & .ReadText(ReadBytes)
            DoEvents
        Loop
        .Close              'Streamを閉じる
    End With
    
    '<x14:dataValidations count= を調べて定義数を確認保存する
    s = InStr(sAll, "<x14:dataValidations") 'sは検索HIT位置
    n = InStrRev(sAll, "</x14:dataValidations>") '最終範囲
    If s > 0 And n > 0 Then
        t = InStr(s + 1, sAll, "count=") '次の位置取得
        sText = Mid(sAll, t + 7, 10) 'count=の後ろの5文字取得
        DVcount = Val(sText) '取得文字列からVal関数で数値取得
    Else
        '見つからない場合抜ける
        MsgBox "<x14:dataValidations>入力規則の定義が見つかりません！"
        Exit Sub
    End If
    '"!#REF!"の位置を調べる
    tREF = InStr(t, sAll, "!#REF!") 'tより後ろの位置検索
    If tREF = 0 Then MsgBox "!#REF!はありませんでした！": Exit Sub
    'エラーの<x14:dataValidation>定義範囲先頭位置取得
    ts = InStrRev(sAll, "<x14:dataValidation ", tREF)
    If ts = 0 Then MsgBox "定義範囲が不明です！": Exit Sub
    'エラーが定義範囲内ならその定義を削除する処理
    If t < ts And ts < tREF Then
        '定義範囲の最終位置を特定する
        tn = InStr(tREF, sAll, "</x14:dataValidation>") + 20 '+20文字
        If tn = 0 Then MsgBox "定義範囲が不明です！": Exit Sub
        If tREF < tn Then con = con + 1   '削除対象件数をカウント
        '定義の文字列を変数に保存
        RepStr = Mid(sAll, ts, tn - ts + 1)
        '定義文字列をReplaceで削除して保存用の別テキストに書き込む
        sAllr = Replace(sAll, RepStr, "")
        '削除した定義をセルに書き込む（E列）
        Cells(con + 1, 11) = con
        Cells(con + 1, 12) = RepStr
        '二つ目以降の"!#REF!"を繰り返し調べる
        Do While tREF > 0
            tREF = InStr(sAllr, "!#REF!") 'HIT位置取得
            If tREF > 0 And tREF < tn Then
                con = con + 1   '削除対象件数を追加カウント
                'エラー範囲の先頭位置と終了位置を取得
                ts = InStrRev(sAllr, "<x14:dataValidation ", tREF)
                tn = InStr(tREF, sAllr, "</x14:dataValidation>") + 20
                '定義範囲の文字列を変数に保存
                RepStr = Mid(sAllr, ts, tn - ts + 1)
                '定義文字列をReplaceで削除して上書き
                sAllr = Replace(sAllr, RepStr, "")
                '削除した定義をセルに書き込む（E列）
                Cells(con + 1, 11) = con
                Cells(con + 1, 12) = RepStr
            End If
        Loop
    End If
    '定義カウント値を変更する処理
    If con >= DVcount Then
        '定義数と同数以上だった場合は定義全体を元のテキストから削除する
        rText = Mid(sAll, s, n + 21) '21文字分下げる
        sAllr = Replace(sAll, rText, "")
    Else
        '定義数を DVcount から con マイナスに書き換える
        rText = Replace(sText, DVcount, DVcount - con)
        sAllr = Replace(sAllr, sText, rText)
    End If
    '"!#REF!"fix後のデータをADODB.Streamでファイルに上書きする処理
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open               'Streamオブジェクトを開く
        .WriteText sAllr    'Streamに書き込む
        .SaveToFile (tgf), 2 'Streamをファイルに上書き保存(2)
        .Close              'Streamを閉じる
    End With
    MsgBox "「入力規則」エラー!#REF!の削除が完了しました！"
    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