ExcelでURLのステータスチェック

Excelの関数等を使って動的サイトのURLをどばぁーっと作って管理してたりしてませんか？
表示確認するときに一旦一覧にまとめて、そこからごっそりクリックしてチェックかけてませんか？
巡回ソフトとか使ってもいいんですが、痒いところに手が届かない感があってどうも。。。

なのでVBAを使ってしっぽりやってみました。

Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private objHTTP As Object

' URLのステータスをチェック。404ページは背景を赤にする
Sub URLStatusChecking()
    Dim c As Range
    For Each c In Selection
        If LCase(c.value) Like "http://*" Or LCase(c.value) Like "https://*" Then
            DoByStatus c.value, c
            'Sleep 200    'サーバに負荷かけたくないときは適宜
            DoEvents      'ESCで離脱
        End If
    Next
    Set objHTTP = Nothing
End Sub

' URLのステータス毎に処理を実行
Function DoByStatus(url As String, c As Range)
    Dim statusCode As Variant
    Dim redirectUrl As String
    
    statusCode = CheckURL(url)
    'Debug.Print url & ": " & statusCode
    
    If statusCode = 200 Then
        '
    ElseIf statusCode = 404 Then
        ' ページが存在しない場合は背景色を赤に設定
        c.Interior.Color = RGB(255, 128, 128)
    ElseIf statusCode = 301 Or statusCode = 302 Then
        ' リダイレクトの場合は再帰的に処理をする
        'Debug.Print objHTTP.GetAllResponseHeaders
         redirectUrl = getLocation(objHTTP.GetAllResponseHeaders)
         DoByStatus redirectUrl, c
    Else
        c.Interior.Color = RGB(0, 255, 0)
    End If

End Function

' URLのステータスをチェック
Function CheckURL(ByVal strURL As String) As Variant
    Dim num As Variant
    On Error GoTo ErrHandler
    If objHTTP Is Nothing Then
         Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
    End If
    
    objHTTP.Open "HEAD", strURL, False
    objHTTP.Send
    
    CheckURL = objHTTP.status
    Exit Function
ErrHandler:
    If Err() <> 0 Then
        CheckURL = "n.a"
    End If
End Function

' ヘッダ情報からLocationのURLを抜き出す
Function getLocation(headers As String) As String
    Dim lines As Variant
    Dim result As Object
    Dim result2 As Object
    Dim url As String
    Dim re As Object
    
    Set re = CreateObject("VBScript.RegExp")
    lines = Split(headers, vbCrLf)
    For Each l In lines
        With re
            .Pattern = "Location: (.*)"
            .Global = True
        End With
        Set result = re.Execute(l)
        If result.Count > 0 Then
            Set result2 = result(0).SubMatches
            For i = 0 To result2.Count - 1
                url = result2(i)
            Next
        End If
    Next
    
    getLocation = url
    
    Set result = Nothing
    Set result2 = Nothing
    Set re = Nothing
End Function

やっつけ感満載ですが使い捨てのコードだからいいんです。
そういうスクリプトに限ってやたら使い続けたりするんですが、その時はその時にリファクタリングするなりなんなりすればいいだけなので、これでいいんです（笑）