Check If Hyperlink Broken But Only Unique Cells

DataBlake

Well-known Member
Joined
Jan 26, 2015
Messages
779
Office Version
2016
Platform
Windows
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
 

Some videos you may like

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".

DataBlake

Well-known Member
Joined
Jan 26, 2015
Messages
779
Office Version
2016
Platform
Windows
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

Code:
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
Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,099,916
Messages
5,471,488
Members
406,766
Latest member
Parasoner

This Week's Hot Topics

Top