If Hyperlink is Broken, Copy Entire Row To Destination Sheet

user_16704510 0
Viewed 51

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?

vba excel
1 Answers

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
user_98140690
Related