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

'ラベルかどうかチェック
Private Function ExUrlLabelCheck(surl As String) As Boolean
    Dim i As Integer
    Dim nlen As Integer
    Dim s As String

    ExUrlLabelCheck = False
    nlen = Len(surl)
    For i = nlen To 0 Step -1
        s = Mid$(surl, i, 1)
        If s = "#" Then
            ExUrlLabelCheck = True
            Exit For
        ElseIf s = "." Or s = "/" Then
            Exit For
        End If
    Next
End Function


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

'リンクを取り出しセルに記入する
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 tIElink.document.Links.Length - 1
        If Left(tIElink.document.Links(i).href, 4) = "http" Then
            If ExUrlLabelCheck(tIElink.document.Links(i).href) = False Then
                coun = coun + 1
            End If
        End If
    Next
    
    'リンク数分を行の挿入
    Range(Cells(lrow + 1, lcol), Cells(lrow + coun, lcol)).Select
    Selection.EntireRow.Insert
    
    coun = 0
    For i = 0 To tIElink.document.Links.Length - 1
        If Left(tIElink.document.Links(i).href, 4) = "http" Then
            If ExUrlLabelCheck(tIElink.document.Links(i).href) = False Then
                'セルに記入
                Cells(lrow + coun + 1, lcol) = tIElink.document.Links(i).href
                coun = coun + 1
            End If
        End If
    Next
    
    ExGetLinkLink = coun
End Function