vba - 使用VBA在excel中导入网页数据

Question

我想将 MutualFundsPortfolioValues 导入 Excel。我不知道如何从网站导入数据，我需要做的是在所选公司的 2 个不同日期内将 Web 数据导入 Excel ..

当我在 B3 和 B4 单元格中输入日期并单击命令按钮 1 时，Excel 可能会将我网页中的所有数据导入到我的 Excel 工作表“结果”

例如:

date 1: 04/03/2013 <<<< " it will be in sheets "input" cell B3
date 2 : 11/04/2013 <<<<< " it will be in sheet "input " cell B4
choosen companies <<<<<< its Range "B7: B17"

我添加了示例 Excel 工作表和网页的打印屏幕。 有什么想法吗？

我的网页网址:

http://www.spk.gov.tr/apps/MutualFundsPortfolioValues/FundsInfosFP.aspx?ctype=E&submenuheader=0

Excel示例和数据示例图片: http://uploading.com/folders/get/b491mfb6/excel-web-query

Answer 1

这是使用 IE Automation 导入数据的代码。

Input Parameters (Enter in Sheet1 as per screenshot below)
start date = B3
end date = B4
Şirketler = B5 (It allows multiples values which should appear below B5 and so on)

ViewSource of page 输入字段

代码的工作原理:

• 代码创建 Internet Explorer 对象并导航到 site
• 等待页面完全加载并准备就绪。 (IE.就绪状态)
• 创建对象 html 类
• 为工作表 1 中的输入字段输入值(txtDateBegin、txtDateEnd、lstCompany)
• 点击提交按钮
• 遍历表 dgFunds 的每一行并转储到 excel Sheet2

代码:

   Dim IE As Object
Sub Website()


    Dim Doc As Object, lastRow As Long, tblTR As Object
    Set IE = CreateObject("internetexplorer.application")
    IE.Visible = True

navigate:
    IE.navigate "http://www.spk.gov.tr/apps/MutualFundsPortfolioValues/FundsInfosFP.aspx?ctype=E&submenuheader=0"

    Do While IE.readystate <> 4: DoEvents: Loop

    Set Doc = CreateObject("htmlfile")
    Set Doc = IE.document

    If Doc Is Nothing Then GoTo navigate

    Set txtDtBegin = Doc.getelementbyid("txtDateBegin")
    txtDtBegin.Value = Format(Sheet1.Range("B3").Value, "dd.MM.yyyy")

    Set txtDtEnd = Doc.getelementbyid("txtDateEnd")
    txtDtEnd.Value = Format(Sheet1.Range("B4").Value, "dd.MM.yyyy")


    lastRow = Sheet1.Range("B65000").End(xlUp).row
    If lastRow < 5 Then Exit Sub

    For i = 5 To lastRow

        Set company = Doc.getelementbyid("lstCompany")
        For x = 0 To company.Options.Length - 1
            If company.Options(x).Text = Sheet1.Range("B" & i) Then
                company.selectedIndex = x

                Set btnCompanyAdd = Doc.getelementbyid("btnCompanyAdd")
                btnCompanyAdd.Click
                Set btnCompanyAdd = Nothing

                wait
                Exit For
            End If
        Next
    Next


    wait

    Set btnSubmit = Doc.getelementbyid("btnSubmit")
    btnSubmit.Click

    wait

    Set tbldgFunds = Doc.getelementbyid("dgFunds")
    Set tblTR = tbldgFunds.getelementsbytagname("tr")



    Dim row As Long, col As Long
    row = 1
    col = 1

    On Error Resume Next

    For Each r In tblTR

        If row = 1 Then
            For Each cell In r.getelementsbytagname("th")
                Sheet2.Cells(row, col) = cell.innerText
                col = col + 1
            Next
            row = row + 1
            col = 1
        Else
            For Each cell In r.getelementsbytagname("td")
                Sheet2.Cells(row, col) = cell.innerText
                col = col + 1
            Next
            row = row + 1
            col = 1
        End If
    Next

    IE.Quit
    Set IE = Nothing

    MsgBox "Done"

End Sub

Sub wait()
    Application.wait Now + TimeSerial(0, 0, 10)
    Do While IE.readystate <> 4: DoEvents: Loop
End Sub

工作表 2 中的输出表

HTH