If Hyperlink is Broken, Copy Entire Row To Destination Sheet - excel

Question

I want to copy entire row to destination sheet if either: 1) there are no hyperlinks in the row, or 2) the hyperlinks in the row are all broken links (e.g., they return an error when accessed).
Sub Find_Value()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim rFind As Range
Dim i As Long
Set sh1 = Sheets("data")
Set sh2 = Sheets("copy")
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(i, 1).Hyperlinks.Count = 0 Then
Cells(i, "A").EntireRow.Copy Destination:=sh2.Cells(i, "A").End(xlUp).Offset(1)
Else
End If
Next i
End Sub
I can do it for if there are no hyperlinks (shown in my code above), but how can I check if the links are broken?

Answer 1

Check If No Hyperlink Or Link Is Broken
Option Explicit
Sub FindValue()
Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets("data")
Dim srg As Range
Set srg = sws.Range("A1", sws.Cells(sws.Rows.Count, "A").End(xlUp))
Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets("copy")
Dim dCell As Range: Set dCell = dws.Cells(dws.Rows.Count, "A").End(xlUp)
Dim sCell As Range
Dim rCount As Long
Dim Invalid As Boolean
For Each sCell In srg.Cells
If sCell.Hyperlinks.Count = 0 Then
Invalid = True
Else
If IsLinkBroken(sCell.Hyperlinks(1).Address) Then Invalid = True
End If
If Invalid Then
Set dCell = dCell.Offset(1)
sCell.EntireRow.Copy Destination:=dCell
rCount = rCount + 1
Invalid = False
End If
Next sCell
MsgBox "Rows copied: " & rCount, vbInformation
End Sub
Function IsLinkBroken(ByVal url As String) As Boolean
On Error GoTo ClearError
With CreateObject("MSXML2.ServerXMLHTTP")
.Open "HEAD", url, False
.send
If .Status = 200 Then Exit Function
End With
ProcExit:
IsLinkBroken = True
Exit Function
ClearError:
Resume ProcExit
End Function
Compact
Not quite sure if this may be much faster (or even correct).
Sub FindValueCompact()
Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets("data")
Dim srg As Range
Set srg = sws.Range("A1", sws.Cells(sws.Rows.Count, "A").End(xlUp))
Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets("copy")
Dim dCell As Range: Set dCell = dws.Cells(dws.Rows.Count, "A").End(xlUp)
Dim xhr As Object: Set xhr = CreateObject("MSXML2.ServerXMLHTTP")
Dim sCell As Range
Dim rCount As Long
Dim ErrNum As Long
Dim Invalid As Boolean
For Each sCell In srg.Cells
If sCell.Hyperlinks.Count = 0 Then
Invalid = True
Else
xhr.Open "HEAD", sCell.Hyperlinks(1).Address, False
On Error Resume Next
xhr.send
ErrNum = Err.Number
On Error GoTo 0
If ErrNum = 0 Then
If xhr.Status <> 200 Then Invalid = True
Else
Invalid = True
ErrNum = 0
End If
End If
If Invalid Then
Set dCell = dCell.Offset(1)
sCell.EntireRow.Copy Destination:=dCell
rCount = rCount + 1
Invalid = False
End If
Next sCell
MsgBox "Rows copied: " & rCount, vbInformation
End Sub