VBA爬取赛马站点HTML链接写入Excel出现垂直空行故障求解

问题原因 #

• 现有代码遍历目标表格下所有<tr>标签，包含大量无有效链接的表头行、空行，且无论是否成功提取到有效href，都会对行号r执行+1操作，未提取到内容的行就形成了空白间隔
• 未按需求筛选notStrikeout类的目标元素，引入了大量无关节点遍历
• 代码中声明创建的IE对象全程未使用，属于冗余逻辑

修复说明 #

调整遍历逻辑，仅在成功提取到带notStrikeout类的有效链接时才写入单元格并累加行号，同时删除冗余的IE相关代码，避免不必要的资源占用。
使用前请确保VBA编辑器已勾选引用：工具→引用→Microsoft HTML Object Library、Microsoft XML, v6.0

修正后完整代码 #

Sub Horse5()
    Dim ws As Worksheet
    Dim http As New XMLHTTP60, html As New HTMLDocument
    Dim node As HTMLHtmlElement, nodeTr As HTMLHtmlElement
    Dim aTag6 As HTMLAnchorElement, aTag7 As HTMLAnchorElement
    Dim r As Long, c As Long
    
    Application.ScreenUpdating = False
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    r = 1 ' 起始行可根据需求调整
    c = 4 ' 起始列可根据需求调整
    
    ' 请求页面内容
    With http
        .Open "GET", "https://www.racingandsports.com/form-guide/thoroughbred/australia/ballarat/2021-08-29/R1", False
        .send
        html.body.innerHTML = .responseText
    End With
    
    ' 遍历目标表格
    For Each node In html.getElementsByClassName("hidden-xs table-responsive marginTop fgr-table-lvl-1")
        For Each nodeTr In node.getElementsByTagName("tr")
            With nodeTr.getElementsByTagName("td")
                If .Length >= 8 Then ' 确保存在第6、7位td（索引从0开始）
                    ' 筛选带notStrikeout类的a标签
                    On Error Resume Next
                    Set aTag6 = .Item(6).getElementsByTagName("a")(0)
                    Set aTag7 = .Item(7).getElementsByTagName("a")(0)
                    On Error GoTo 0
                    
                    ' 仅当至少拿到一个有效链接时才写入，避免空行
                    If Not aTag6 Is Nothing Then
                        If aTag6.className = "notStrikeout" Then
                            ws.Cells(r, c + 6) = aTag6.href
                            If Not aTag7 Is Nothing And aTag7.className = "notStrikeout" Then
                                ws.Cells(r, c + 7) = aTag7.href
                            End If
                            r = r + 1 ' 仅有效内容行累加行号
                        End If
                    End If
                    ' 重置标签变量，避免上次结果干扰
                    Set aTag6 = Nothing
                    Set aTag7 = Nothing
                End If
            End With
        Next
    Next
    
    Application.ScreenUpdating = True
    MsgBox "input complete"
End Sub

内容的提问来源于stack exchange，提问作者NewGuy1