Excelでリンク切れチェックソフトを作ってみよう

'リンク先IEオープン
Private Function ExLinkopen(lrow As Long, lcol As Long) As Boolean
    Dim sttime As Long
    Dim passtime As Long
    Dim s1 As String
    Dim s2 As String
    
    ExLinkopen = False
On Error GoTo ErrExit
    Set tIElink = CreateObject("InternetExplorer.application")
    tIElink.navigate Cells(lrow, lcol)
    '読み込みが終わるまで30秒待つ
    Label2.Visible = True
    sttime = Timer
    Do
        '経過時間を算出
        passtime = Timer - sttime
        Label2.Caption = "リンク先をオープンしています。 (" & passtime & ")"
        DoEvents
        If passtime >= 30 Then
            Exit Do
        End If
        '読込み完了
        If tIElink.ReadyState = 4 Then
            Exit Do
        End If
    Loop
    If tIElink.ReadyState = 4 Then
        If LCase(tIElink.document.URL) = LCase(Cells(lrow, lcol)) Then
            Cells(lrow, lcol + 1) = "○"
            Cells(lrow, lcol + 2) = tIElink.document.Title

            If srcLinkPath = Left(LCase(Cells(lrow, lcol)), Len(srcLinkPath)) Then
                If ExDoneSearchUrl(lrow, lcol, s1, s2) = False Then
                    If ExUrlLabelCheck(Cells(lrow, lcol), s1) = False Then
                        ExGetLinkLink lrow, lcol
                    Else
                        If ExSearchLabel(s1, tIElink.document.body.innerHTML) = False Then
                            Cells(lrow, lcol + 1) = "×"
                        End If
                    End If
                End If
            End If
            ExLinkopen = True
        End If
    End If
    If ExLinkopen = False Then
        Cells(lrow, lcol + 1) = "×"
    End If
ErrResume:
On Error Resume Next
    tIElink.Quit
    Set tIElink = Nothing
    Label2.Visible = False
    Exit Function
ErrExit:
    Resume ErrResume
End Function

下記のVBAコードを追加してください。

'アンカーの有無をチェック
Private Function ExSearchLabel(slbl As String, sbody As String) As Boolean
    Dim ln1 As Long
    Dim ln2 As Long
    Dim pos As Long
    Dim s1 As String
    Dim s2 As String
    Dim s3 As String
    
    ExSearchLabel = False
    pos = 1
    Do
        ln1 = InStr(pos, sbody, slbl)
        If ln1 > 0 Then
            n = ln1 - 100
            If n < 1 Then n = 1
            '前の100文字をチェック
            s1 = LCase(Mid(sbody, n, 100 + Len(slbl)))
            'Debug.Print s1
            '空白を削除する
            s3 = ""
            For i = 1 To Len(s1)
                s2 = Mid(s1, i, 1)
                If s2 <> " " And s2 <> "　" Then
                    s3 = s3 & s2
                End If
            Next
            
            ln2 = InStr(1, s3, "aname=" & slbl)
            If ln2 > 0 Then
                ExSearchLabel = True
                Exit Do
            End If
            pos = pos + ln1 + 1
        Else
            Exit Do
        End If
    Loop
End Function