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

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

2 个答案: