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

Step 8 既にチェック済みか確認

同じサイトにリンクしていることがよくありますが、既にチェックし結果OKの場合はパスするよう検索します。検索は、Find を使用し、見つかれば○印があるかどうか確認します。○印でなければ、念のため再度チェックします。検索は調査行より一つ上の行の範囲で行います。


Homeへ > Excelでアプリケーションソフト2 > リンク切れチェックソフト

シート画面

既にチェック済みで結果が○の場合は、○を付けパスします。
リンクがOKの場合は○印


シートのVBAコード

下記のコードを入力してください。

'既にチェック済みか確認
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


Homeへ > Excelでアプリケーションソフト2 > リンク切れチェックソフト

■■■
このサイトの内容を利用して発生した、いかなる問題にも一切責任は負いませんのでご了承下さい
■■■
当ホームページに掲載されているあらゆる内容の無許可転載・転用を禁止します


Copyright (c) Excel-Excel ! All rights reserved