无法从网页获取数据 - DOM 查询

Question

我使用该代码自动从网站获取一些字段并用搜索结果填充 excel 表，但我认为网站上发生了一些变化，我无法让这段代码再次工作......有什么帮助，建议吗？

Sub Scramble_NAVY_search()
Dim cel As Range, ms As Worksheet, dom As HTMLDocument
Set ms = Sheets("Scramble")
'Const searchUrl = "http://www.scramble.nl/index.php?option=com_mildb&view=search"
For Each cel In ms.Range("B2:B" & ms.Range("B" & Rows.Count).End(xlUp).Row).SpecialCells(2)
    Set dom = New HTMLDocument
    Application.ScreenUpdating = False
    With CreateObject("winhttp.winhttprequest.5.1")
        .Open "POST", searchUrl, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .send "Itemid=60&af=usn&serial=" & cel & "&sbm=Search&code=&searchtype=&unit=&cn="
        dom.body.innerHTML = .responseText
    End With
    On Error Resume Next
    With cel
        If .Offset(, -1).Value = "" Then
            .Offset(, 2) = dom.getElementsByClassName("rowBord")(0).Cells(1).innerText 'Code
            .Offset(, -1) = dom.getElementsByClassName("rowBord")(0).Cells(2).innerText 'Type
            .Offset(, 10) = dom.getElementsByClassName("rowBord")(0).Cells(3).innerText 'C/N
            .Offset(, 3) = dom.getElementsByClassName("rowBord")(0).Cells(4).innerText 'Unit
            .Offset(, 11) = dom.getElementsByClassName("rowBord")(0).Cells(5).innerText 'Status
        End If
    End With
   Next
    End Sub

Answer 1

首先，声明您的searchUrl的行已被注释掉。我不确定这是否是故意和故意的。因此，首先删除Const searchUrl前面的'。

其次，将你的searchUrl更改为此(基本上将http更改为https(：

https://www.scramble.nl/index.php?option=com_mildb&view=search

最后，我已经在您的帖子中编辑了代码格式。 接受编辑并使用该格式。那里有一些换行符会给出错误。

你应该准备好了。

Answer 2

这是一个稍微更有效的重写。我将winhttp.winhttprequest.5.1和dom对象的创建移出循环，以避免不断创建和破坏。Screenupdating移出，因此仅在开始和结束时处理。将返回的记录和循环范围设置为变量，以便从中访问。

通常，我会加载值以循环到数组中并循环数组。我会将结果存储在数组中并在末尾写出一次，因为不断触摸工作表是昂贵的。由于我不知道其他列中发生了什么，并且您的数据范围似乎可能存在差距，因此我没有进行这些修改。

Option Explicit
Public Sub ScrambleNavySearch()
    Dim cel As Range, ms As Worksheet, dom As HTMLDocument, loopRange As Range
    Const SEARCH_URL As String = "https://www.scramble.nl/index.php?option=com_mildb&view=search"
    Set ms = ThisWorkbook.Worksheets("Scramble")
    Set dom = New HTMLDocument
    Set loopRange = ms.Range("B2:B" & ms.Range("B" & rows.Count).End(xlUp).Row).SpecialCells(2)
    Application.ScreenUpdating = False
    With CreateObject("winhttp.winhttprequest.5.1")
        For Each cel In loopRange
            .Open "POST", SEARCH_URL, False
            .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
            .send "Itemid=60&af=usn&serial=" & cel & "&sbm=Search&code=&searchtype=&unit=&cn="
            dom.body.innerHTML = .responseText
            Dim recordFields As Object
            Set recordFields = dom.querySelectorAll(".rowBord td")
            If recordFields.Length > 0 Then
                With cel
                    .Offset(, -1) = recordFields.item(2).innerText 'Type
                    .Offset(, 2) = recordFields.item(1).innerText 'Code
                    .Offset(, 3) = recordFields.item(4).innerText 'Unit
                    .Offset(, 10) = recordFields.item(3).innerText 'C/N
                    .Offset(, 11) = recordFields.item(5).innerText 'Status
                End With
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub