Help Updating URL Checking Code to Skip Cells and Add Text if Missing a URL

[CatLadee]

Hoping for a little help with the updates to this code indicated below. Really appreciate your time and input and sending the most positive karma your way! - The Cat Ladee


Sub ValidateURLs()


Dim Cell As Range
Dim Rng As Range
Dim RngEnd As Range
Dim Status As String
Dim Wks As Worksheet

Set Wks = ActiveSheet
Set Rng = Wks.Range("F2")

Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)

For Each Cell In Rng 'EXCEPT BLANK CELLS, CELLS CONTAINING THE TEXT "mailto:", AND THE CELL WITH "https://www.state.gov/travel/"
Status = GetURLStatus(Cell)
If (Status <> "200 - OK") And (Status <> "301 - Moved Permanently") And (Status <> "302 - Moved Temporarily") And (Status <> "401 - Unauthorized") And (Status <> "302 - Found") Then
Cell.Offset(0, 1) = Status
End If
Next Cell


'If BLANK CELLS Then Cell.Offset(0, 1) = "Missing URL"

End Sub

 

[sericom]

Is this what you're after

Sub ValidateURLs()


Dim Cell As Range
Dim Rng As Range
Dim RngEnd As Range
Dim Status As String
Dim Wks As Worksheet

Set Wks = ActiveSheet
Set Rng = Wks.Range("F2")

Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)

For Each Cell In Rng
    If Cell = "" Or Cell = "mailto:" Or Cell = "https://www.state.gov/travel/" Then
        Cell.Offset(0, 1) = "Missing URL"
    Else
        Status = GetURLStatus(Cell)
        If (Status <> "200 - OK") And (Status <> "301 - Moved Permanently") And (Status <> "302 - Moved Temporarily") And (Status <> "401 - Unauthorized") And (Status <> "302 - Found") Then
            Cell.Offset(0, 1) = Status
        End If
    End If
Next Cell
End Sub

 

[CatLadee]

Sort of! Not exactly but helpful nonetheless - really appreciate you!