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

'既にチェック済みか確認
Private Function ExDoneSearchUrl(lrow As Long, lcol As Long, ByRef sres) As Boolean
    Dim trange As Range
    Dim surl As String
    
    ExDoneSearchUrl = True
    surl = LCase(Cells(lrow, lcol))
    If surl = LCase(TextBox1) Then
        sres = "○"
        Exit Function
    End If
    
    If lrow > 10 Then
        Set trange = ActiveSheet.Range(Cells(10, 2), Cells(lrow - 1, 2))_
.Find(What:=surl, LookIn:=xlValues, LookAt:=xlWhole)
        If Not trange Is Nothing Then
            sres = Cells(trange.Row, 3)
            Exit Function
        End If
    End If
    ExDoneSearchUrl = False
End Function

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

Private Sub CommandButton1_Click()
    Dim llink As Long
    Dim nowrow As Long
    Dim nowcol As Long
    Dim s1 As String
    Dim flag As Boolean
    
    If TextBox1 = "" Then
        MsgBox "チェックするURLを入力してください。"
        TextBox1.Activate
        Exit Sub
    End If
    
    s1 = ExGetExt(TextBox1.Text)
    If LCase(s1) <> "html" And LCase(s1) <> "shtml" Then
        MsgBox "チェックするURLは、html か shtml ファイルを指定してください。"
        TextBox1.Activate
        Exit Sub
    End If
    
    ExGetSrcLinkPath TextBox1.Text
    If srcLinkPath = "" Then
        MsgBox "チェックするURLから、/ 文字が見つかりません。URLが正しくないようです。"
        TextBox1.Activate
        Exit Sub
    End If
    
    Cells.Clear
    'IEオープン
    If ExCreateIEobject Then
        nowrow = 10
        nowcol = 2
        'リンクを取り出しセルに記入する
        llink = ExGetLink(nowrow, nowcol)
        If llink > 0 Then
            Do
                flag = False
                If ExDoneSearchUrl(nowrow, nowcol, s1) Then
                    If s1 = "○" Then
                        Cells(nowrow, nowcol + 1) = "○"
                        flag = True
                    End If
                End If
                
                If flag = False Then
                    'リンク先IEオープン
                    ExLinkopen nowrow, nowcol
                End If
                nowrow = nowrow + 1
                If Cells(nowrow, nowcol) = "" Then
                    Exit Do
                End If
            Loop
        End If
    End If
    
On Error Resume Next
    tIEobj.Quit
    Set tIEobj = Nothing
End Sub