没有显示将目标表从HTML复制到Excel

Question

尝试从HTML文件中选择下拉列表并尝试将结果表复制到Excel中。但下面的代码处理来自HTML的其他文本而不是表格（我想填充到Excel）。

Option Explicit

'VBE > Tools > References:
' Microsoft Internet Controls
Public Sub MakeSelections()
    Dim ie As InternetExplorer, ele As Object, t As Date
    Const MAX_WAIT_SEC As Long = 5
    Dim commodity As String, iDate As String


    commodity = "MADHYA PRADESH"
    iDate = "REWA"

    Set ie = New InternetExplorer

    With ie
        .Visible = True
        .Navigate2 "http://hydro.imd.gov.in/hydrometweb/(S(3qitcijd521egpzhwqq3jk55))/DistrictRaifall.aspx"

        While .Busy Or .readyState < 4: DoEvents: Wend

        .document.querySelector("[value='" & commodity & "']").Selected = True
        .document.querySelector("[name=listItems]").FireEvent "onchange"
        t = Timer
        Do
            On Error Resume Next
            Set ele = .document.querySelector("[value='" & iDate & "']")
            On Error GoTo 0
            If Timer - t > MAX_WAIT_SEC Then Exit Do
        Loop While ele Is Nothing

        If Not ele Is Nothing Then
            ele.Selected = True
            .document.querySelector("#GoBtn").Click
        Else
            Exit Sub
        End If
        'Stop
        '.Quit


   Dim doc As Object, hTable As Object, hBody As Object, hTR As Object, hTD As Object
   Dim tb As Object, bb As Object, tr As Object, td As Object

   Dim y As Long, z As Long, wb As Excel.Workbook, ws As Excel.Worksheet

     Set wb = Excel.ActiveWorkbook
     Set ws = wb.ActiveSheet

      y = 1   'Column A in Excel
      z = 1   'Row 1 in Excel

     Set doc = ie.document
     Set hTable = doc.getElementsByTagName("table")
     For Each tb In hTable

        Set hBody = tb.getElementsByTagName("tbody")
        For Each bb In hBody

            Set hTR = bb.getElementsByTagName("tr")
            For Each tr In hTR


                 Set hTD = tr.getElementsByTagName("td")
                 y = 1 ' Resets back to column A
                 For Each td In hTD
                   ws.Cells(z, y).Value = td.innerText
                   y = y + 1
                 Next td
                 DoEvents
                 z = z + 1
            Next tr
            Exit For
        Next bb
    Exit For
  Next tb
    End With

End Sub

Answer 1

我会使用剪贴板和定时循环。有重新保理的余地，我稍后会做。

该页面对结果执行xhr POST请求，因此请使用您可能能够复制的开发工具。它使用这个网址：http://hydro.imd.gov.in/hydrometweb/(S(yir33wzdcp5kls450czjmh45))/DistrictRaifall.aspx。最后看评论。

Option Explicit    
'VBE > Tools > References:
' Microsoft Internet Controls
Public Sub MakeSelections()
    Dim ie As InternetExplorer, commodity As String, iDate As String, clipboard As Object, arr()

    Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    Set ie = New InternetExplorer
    commodity = "MADHYA PRADESH"
    iDate = "REWA"

    With ie
        .Visible = True
        .Navigate2 "http://hydro.imd.gov.in/hydrometweb/(S(3qitcijd521egpzhwqq3jk55))/DistrictRaifall.aspx"

        While .Busy Or .readyState < 4: DoEvents: Wend

        .document.querySelector("[value='" & commodity & "']").Selected = True
        .document.querySelector("[name=listItems]").FireEvent "onchange"

        arr = ElementFound(.document, "[value='" & iDate & "']")

        If Not arr(0) Then Exit Sub

        arr(1).Selected = True
        .document.querySelector("#GoBtn").Click

        arr = ElementFound(.document, "#GridId")

        If Not arr(0) Then Exit Sub

        clipboard.SetText arr(1).outerHTML
        clipboard.PutInClipboard
        ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).PasteSpecial
        .Quit
    End With
End Sub

Public Function ElementFound(ByRef document As Object, ByVal selector As String) As Variant
    Dim ele As Object, t As Date, arr(0 To 1)
    Const MAX_WAIT_SEC As Long = 5
    t = Timer
    Do
        On Error Resume Next
        Set ele = document.querySelector(selector)
        On Error GoTo 0
        If Timer - t > MAX_WAIT_SEC Then Exit Do
    Loop While ele Is Nothing
    If Not ele Is Nothing Then
        arr(0) = True
    Else
        arr(0) = False
    End If
    Set arr(1) = ele
    ElementFound = arr
End Function

---

XHR：

POST主体包含参数

__EVENTTARGET：vbNullString

__EVENTARGUMENT：vbNullString

__LASTFOCUS：vbNullString

__VIEWSTATE：获得。在我的情况下，至少从之前的GET中获得这个并不起作用

__VIEWSTATEGENERATOR：6C290774'<静态，但可以从之前的GET获得

listItems：MADHYA PRADESH'用+替换空格

地区掉落清单：REWA

GoBtn：GO