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

'リンクを取り出しセルに記入する
Private Function ExGetLinkLink(lrow As Long, lcol As Long) As Long
    Dim i As Integer
    Dim s1 As String
    Dim coun As Long
    
    coun = 0
    For i = 0 To tIEobj.document.Links.Length - 1
        If Left(tIEobj.document.Links(i).href, 4) = "http" Then
            coun = coun + 1
        End If
    Next
    
    'リンク数分を行の挿入
    Range(Cells(lrow + 1, lcol), Cells(lrow + coun, lcol)).Select
    Selection.EntireRow.Insert
    
    For i = 0 To tIEobj.document.Links.Length - 1
        If Left(tIEobj.document.Links(i).href, 4) = "http" Then
            'セルに記入
            Cells(lrow + i + 1, lcol) = tIEobj.document.Links(i).href
        End If
    Next
    
    ExGetLinkLink = coun
End Function


下記のVBAコードに変更してください。

'リンク先IEオープン
Private Function ExLinkopen(lrow As Long, lcol As Long) As Boolean
    Dim sttime As Long
    Dim passtime As Long
    Dim tIElink As Object
    
    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) = "○"
            ExGetLinkLink lrow, lcol
            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