excel - 如果超链接断开，则将整行复制到目标工作表

Question

如果出现以下任一情况，我想将整行复制到目标工作表:1) 行中没有超链接，或 2) 行中的超链接都是断开的链接(例如，它们在访问时返回错误)。

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

如果没有超链接(如我上面的代码所示)，我可以这样做，但是如何检查链接是否损坏？

Answer 1

检查是否没有超链接或链接损坏

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

紧凑型

不太确定这是否会更快(甚至正确)。

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