IE快速自动化

Question

我目前正在尝试使用 VBA 从一个名为 X-Rates 的网站上抓取一些汇率。我目前的问题是运行时间太长。我已将其范围缩小到我的 IE 对象的 Do Events。

我的问题：有没有更好的方法（也许代码效率更高），或者我的逻辑有缺陷？

代码的作用如下：

1 - 每个国家的循环 (1-9 = offsetCurr);

2- 转换为汇率并在单元格上保存价值

    'Define variables
    Dim strElm     As String
    Dim i          As Integer
    Dim ie         As InternetExplorer
    Dim period     As Variant
    Dim offsetCurr As Integer
    Dim offsetDesc As String

    'Define period
    period = Application.InputBox("What's the year and period?", "Period", , , , , 2)

    'Define start row
    i = 2

    Application.ScreenUpdating = False

    On Error GoTo ErrHandler

    For offsetCurr = 1 To 9

        If offsetCurr = 1 Then

            'ARS to EURO
            Set ie = New InternetExplorer
            offsetDesc = "ARS"
            Cells(i, 1).Value = period
            Cells(i, 2).Value = offsetDesc
            ie.navigate "http://www.x-rates.com/calculator/?from=ARS&to=EUR&amount=1"

            Do While ie.readyState <> READYSTATE_COMPLETE
                DoEvents
            Loop

            d = ie.document.getElementsByClassName("ccOutputRslt")(0).innerText
            strElm = d
            Cells(i, 3).Value = strElm

            ie.Quit
            Set ie = Nothing

            'ARS to USD
            Set ie = New InternetExplorer
            ie.navigate "http://www.x-rates.com/calculator/?from=ARS&to=USD&amount=1"

            Do While ie.readyState <> READYSTATE_COMPLETE
                DoEvents
            Loop

            d = ie.document.getElementsByClassName("ccOutputRslt")(0).innerText
            strElm = d
            Cells(i, 4).Value = strElm

            'Quit IE for automation purposes
            ie.Quit
            Set ie = Nothing

            'ARS to GBP
            Set ie = New InternetExplorer
            ie.navigate "http://www.x-rates.com/calculator/?from=ARS&to=GBP&amount=1"

            Do While ie.readyState <> READYSTATE_COMPLETE
                DoEvents
            Loop

            d = ie.document.getElementsByClassName("ccOutputRslt")(0).innerText
            strElm = d
            Cells(i, 5).Value = strElm

            ie.Quit
            Set ie = Nothing

        End If

ErrHandler:

    If Err.Number <> 0 Then
        Msg = "Error #" & Str(Err.Number) & " was generated by " & Err.Source & "." & Chr(13) & "Error description: " & Err.Description
        MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
        Exit Sub
    End If

End Sub

我知道代码量很大，如果需要，我可以编辑问题以使其更简单。

Answer 1

这是一个展示如何通过 XHR 检索费率的示例：

Option Explicit

Sub TestGetRate()

    Dim sCrcy As Variant

    For Each sCrcy In Array("EUR", "USD", "GBP")
        Debug.Print GetRate("ARS", sCrcy)
    Next

End Sub

Function GetRate(sFromCrcy, sToCrcy)

    Dim sUrl, sContent

    sUrl = "http://www.x-rates.com/calculator/?from=" & sFromCrcy & "&to=" & sToCrcy & "&amount=1"
    With CreateObject("MSXML2.XMLHttp")
        .Open "GET", sUrl, False
        .send
        sContent = .ResponseText
    End With
    With CreateObject("VBScript.RegExp")
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = "<span class=""ccOutputRslt"">(.*?)<span class=""ccOutputTrail"">(.*?)</span><span class=""ccOutputCode"">(.*?)</span></span>"
        With .Execute(sContent).Item(0)
            GetRate = .SubMatches(0) & .SubMatches(1) & .SubMatches(2)
        End With
    End With

End Function

我的输出如下：

0.061688 欧元
0.070373 美元
0.048865 英镑

Answer 2

看起来您正在启动一个新的 IE 实例，并为 9 个循环中的每一个循环完全关闭它。尝试在开始时启动一次 IE，然后循环遍历每种货币类型，然后退出 IE。