Question

我有一个VBA代码，该代码可从政府网站上的下拉菜单中选择信息，然后提交查询。然后，请求的数据在另一个IE页面中打开。我正在尝试将此数据复制到excel中；但是，我无法这样做。我的代码当前将文本复制到包含下拉菜单的第一个IE页面上。政府网站为：http://www.osfi-bsif.gc.ca/Eng/wt-ow/Pages/FINDAT.aspx

我在互联网上寻找解决方案，但似乎无济于事...

这是我的代码：

Sub GetOsfiFinancialData()

Dim UrlAddress As String
UrlAddress = "http://ws1.osfi-bsif.gc.ca/WebApps/FINDAT/DTIBanks.aspx?T=0&LANG=E"

Dim ie As Object
Set ie = CreateObject("internetexplorer.application")
With ie
    .Silent = True
    .Visible = False
    .navigate UrlAddress
End With

Do Until Not ie.Busy And ie.readyState = 4
    DoEvents
Loop

Application.Wait (Now() + TimeValue("00:00:05"))

'Select Bank
ie.document.getElementById("DTIWebPartManager_gwpDTIBankControl1_DTIBankControl1_institutionTypeCriteria_institutionsDropDownList").Value = Z005

'open window with financial data
Dim objButton
Set objButton = ie.document.getElementById("DTIWebPartManager_gwpDTIBankControl1_DTIBankControl1_submitButton")
objButton.Focus
objButton.Click

'select new pop-up window
marker = 0
Set objshell = CreateObject("Shell.Application")
IE_count = objshell.Windows.Count
For x = 0 To (IE_count - 1)
    On Error Resume Next    ' sometimes more web pages are counted than are open
    my_title = objshell.Windows(x).document.Title

    If my_title Like "Consolidated Monthly Balance Sheet" & "*" Then 'compare to find if the desired web page is already open
        Set ie = objshell.Windows(x)
        marker = 1
        Exit For
    Else
    End If
Next

Do Until Not ie.Busy And ie.readyState = 4
    DoEvents
Loop

Application.Wait (Now() + TimeValue("00:00:05"))

Dim doc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection
Dim table As MSHTML.HTMLTable
Dim clipboard As MSForms.DataObject

Set doc = ie.document
Set tables = doc.getElementsByTagName("body")
Set table = tables(0)
Set clipboard = New MSForms.DataObject

'paste in sheets
Dim test
Set test = ActiveWorkbook.Sheets("Test")
clipboard.SetText table.outerHTML
clipboard.PutInClipboard
test.Range("A1").PasteSpecial xlPasteAll
clipboard.Clear

MsgBox ("Task Completed")

End Sub

非常感谢您的帮助！

Answer 1

我没有时间去研究从另一个浏览器控制一个浏览器的所有内容，但是我认为您可以弄清楚这一点，特别是因为您已经在此方面取得了很大的进步。像您一样，从URL＃1获取URL＃2，但是周围有一些更好的数据控件，然后执行此操作...

Option Explicit
Sub Web_Table_Option_One()
    Dim xml    As Object
    Dim html   As Object
    Dim objTable As Object
    Dim result As String
    Dim lRow As Long
    Dim lngTable As Long
    Dim lngRow As Long
    Dim lngCol As Long
    Dim ActRw As Long
    Set xml = CreateObject("MSXML2.XMLHTTP.6.0")
    With xml
        .Open "GET", "http://ws1.osfi-bsif.gc.ca/WebApps/Temp/2f40b7ef-d024-4eca-a8a3-fb82153efafaFinancialData.aspx", False
        .send
    End With
    result = xml.responseText
    Set html = CreateObject("htmlfile")
    html.body.innerHTML = result
    Set objTable = html.getElementsByTagName("Table")
    For lngTable = 0 To objTable.Length - 1
        For lngRow = 0 To objTable(lngTable).Rows.Length - 1
            For lngCol = 0 To objTable(lngTable).Rows(lngRow).Cells.Length - 1
                ThisWorkbook.Sheets("Sheet1").Cells(ActRw + lngRow + 1, lngCol + 1) = objTable(lngTable).Rows(lngRow).Cells(lngCol).innerText
            Next lngCol
        Next lngRow
        ActRw = ActRw + objTable(lngTable).Rows.Length + 1
    Next lngTable
End Sub

Answer 2

您正在通过document.Title使用当前测试。我发现，在寻找完整标题的所有窗口中，For Each与复制粘贴弹出窗口outsideHTML的复制结合使用。无需额外的等待时间。

在For Each Loop内，将IE实例重置为新窗口后，可以使用ie.document.url获取新的URL。由于您已经加载了数据，因此我认为也可以直接复制并粘贴。

代码：

Option Explicit
Public Sub GetOsfiFinancialData()
    Dim UrlAddress As String, objButton, ie As Object
    UrlAddress = "http://ws1.osfi-bsif.gc.ca/WebApps/FINDAT/DTIBanks.aspx?T=0&LANG=E"
    Set ie = CreateObject("internetexplorer.application")

    With ie
        .Silent = True
        .Visible = False
        .navigate UrlAddress

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

        .document.getElementById("DTIWebPartManager_gwpDTIBankControl1_DTIBankControl1_institutionTypeCriteria_institutionsDropDownList").Value = "Z005"

        Set objButton = .document.getElementById("DTIWebPartManager_gwpDTIBankControl1_DTIBankControl1_submitButton")
        objButton.Focus
        objButton.Click

        Dim objShellWindows As New SHDocVw.ShellWindows, currentWindow As IWebBrowser2

        For Each currentWindow In objShellWindows
            If currentWindow.document.Title = "Consolidated Monthly Balance Sheet - Banks, Trust and Loan" Then
                Set ie = currentWindow
                Exit For
            End If
        Next

        Dim clipboard As Object
        Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        clipboard.SetText ie.document.body.outerHTML
        clipboard.PutInClipboard
        ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).PasteSpecial
        .Quit
    End With
End Sub

参考（VBE>工具>参考）：

Microsoft Internet控件

VBA：将数据从网站复制到Excel

2 个答案: