Check If Hyperlink Broken But Only Unique Cells

[DataBlake]

Hello all,
I have a predicament where if i run a hyperlink checking VBA sub i may not see my computer for the rest of the evening as it will check over 100,000 hyperlinks
Is there any way to have it only check the first of every hyperlink? basically there are duplicate hyperlinks and i would like it to skip duplicates. Hyperlinks are found in column O

any help would be appreciated

 

[DataBlake]

Hello all,
I have a predicament where if i run a hyperlink checking VBA sub i may not see my computer for the rest of the evening as it will check over 100,000 hyperlinks
Is there any way to have it only check the first of every hyperlink? basically there are duplicate hyperlinks and i would like it to skip duplicates. Hyperlinks are found in column O

any help would be appreciated

Right now i have this workaround that creates a new sheet, deletes the duplicates, checks the links, and then vlookups on the original sheet
I would prefer to just check the unique hyperlinks instead and just do the ConvertHyperlinks and checkLINKS VBAs

Sub Workaround()

    Dim lastRow As Long

    Sheets.Add After:=ActiveSheet
    Sheets("Sheet1").Select
    Columns("O:O").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Columns("A:A").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    ActiveSheet.Range("$A$1:$A" & lastRow).RemoveDuplicates Columns:=1, Header:=xlNo
    Range("A1:A" & lastRow).Select
    Call ConvertToHyperlinks
    Call checkLINKS
    
    Sheets("Sheet1").Select
    Columns("P:P").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    Range("P2").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(IFERROR(VLOOKUP(RC[-1],Sheet2!R1:R1048576,2,FALSE),""err""),""err"",""OK"")"
         Range("P2").AutoFill Destination:=Range("P2:P" & lastRow)
         
    Columns("P:P").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    Columns("P:P").Select
    Selection.Replace What:="#Value!", Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    Cells.Select
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("P2:P" & lastRow _
        ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:XF" & lastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
End Sub

Sub checkLINKS()

Dim alink As Hyperlink
Dim strURL As String
Dim objhttp As Object

If MsgBox("Is the Active Sheet a Sheet with Hyperlinks You Would Like to Check?", vbOKCancel) = vbCancel Then

    Exit Sub

End If

On Error Resume Next
For Each alink In Cells.Hyperlinks
    strURL = alink.Address

    If Left(strURL, 4) <> "http" Then
        strURL = ThisWorkbook.BuiltinDocumentProperties("Hyperlink Base") & strURL
    End If

    Application.StatusBar = "Testing Link: " & strURL
    Set objhttp = CreateObject("MSXML2.XMLHTTP")
    objhttp.Open "HEAD", strURL, False
    objhttp.Send

    If objhttp.statustext <> "OK" Then

        alink.Parent.Select
        ActiveCell.Offset(0, 1).Value = 1
        
    End If

Next alink
Application.StatusBar = False
On Error GoTo 0
MsgBox ("Checking Complete!" & vbCrLf & vbCrLf & "Cells With Broken or Suspect Links are Highlighted in RED.")

End Sub