使用VBA拉取所有商店位置

Question

我对VBA比较陌生，但我一直在努力为多个网站做同样的事情，这就是拉动某个公司的所有商店位置。例如，http://freshpet.com/storelocator/。由于距离半径有限，我的代码循环遍历美国所有邮政编码的列表，逐个输入，然后在结果页面上提取信息。这需要花费数小时才能运行并显着降低我的计算机速度，所以有人知道使用VBA处理地图结果的更有效方法吗？

非常感谢提前。

Public Sub FRPT_LOC()
Dim I As Long, IE As Object
Dim zips As Range, zipcell As Range
Dim zipcode As Object, radius As Object
Dim form As Variant, button As Variant
Dim btn As Object, btn_Radius As Object, tb_output As Object
Dim URL As String, str_output As String, arr_output() As String, row As Long
Dim Shell As Object
Dim Doc As HTMLDocument
Dim NodeList
Dim Elem
Dim X
    'Set variables
Dim QuestionList As IHTMLElement
Dim Questions As IHTMLElementCollection
Dim Question As IHTMLElement
Dim RowNumber As Long
Dim QuestionId As String
Dim QuestionFields As IHTMLElementCollection
Dim QuestionField As IHTMLElement
Dim result_address As String
Dim result_phone As String
Dim result_brands As String
Dim QuestionFieldLinks As IHTMLElementCollection

Set zips = Worksheets("Codes").Range("A1:A2")
RowNumber = 3

'clear stores on worksheet
With Worksheets("Stores")
    .Cells.clear
    .Range("a1").value = "result_name"
    .Range("B1").value = "result_address"
    .Range("C1").value = "result_phone"
    .Range("D1").value = "Dognation"
    .Range("E1").value = "Vital"
    .Range("F1").value = "Dog Joy"
    .Range("G1").value = "Freshpet Select"
    .Range("H1").value = "Frozen Treats"
    .Range("G1").value = "Fresh Baked"

End With

'Initiate IE
Set IE = New InternetExplorer
IE.visible = True

'Navigate
IE.Navigate "http://freshpet.com/storelocator/"
Do Until IE.ReadyState = READYSTATE_COMPLETE
Loop

Set radius = IE.Document.getElementById("location_search_distance_field")
radius.value = "50"
Set zipcode = IE.Document.getElementById("location_search_zip_field")
Set btn_Radius = IE.Document.getElementsByTagName("Input")

For Each zipcell In zips
    zipcode.value = zipcell.value

        For Each btn In btn_Radius
            If btn.value = "Search" Then
                btn.Click
            End If
        Next
    Set Doc = IE.Document
    Set QuestionList = Doc.getElementById("results")
    Set Questions = QuestionList.children

    For Each Question In Questions
    'if this is the tag containing the question details, process it
    Set QuestionFields = Question.all
    For Each QuestionField In QuestionFields
        If QuestionField.className = "result_name" Then
            'first get and store the question id in first column
           result_name = Replace(QuestionField.innerText, "result_name", "")
           result_name = Replace(result_name, "result_name", "")
            Worksheets("stores").Cells(RowNumber, 1).value = Trim(result_name)
            'get a list of all of the parts of this question,
            'and loop over them
            End If
        Next QuestionField
            Set QuestionFields = Question.all
    For Each QuestionField In QuestionFields
    'if this is the question's votes, store it (get rid of any surrounding text)
        If QuestionField.className = "result_address" Then
            result_address = Replace(QuestionField.innerText, "result_name", "")
            result_address = Replace(result_address, "result_address", "")
            Worksheets("stores").Cells(RowNumber, 2).value = Trim(result_address)
        End If
        'likewise for views (getting rid of any text)
        If QuestionField.className = "result_phone" Then
            result_phone = QuestionField.innerText
            result_phone = Replace(result_phone, "result_phone", "")
            result_phone = Replace(result_phone, "result_phone", "")
            Worksheets("stores").Cells(RowNumber, 3).value = Trim(result_phone)
        End If
        'if this is the bit where author's name is ...
        If QuestionField.className = "sl-brand sl-brand-dognation" Then
        'get a list of all elements within, and store the
        'text in the second one
            Set QuestionFieldLinks = QuestionField.all
            Worksheets("stores").Cells(RowNumber, 4).value = "Dognation"
        End If
        If QuestionField.className = "sl-brand sl-brand-dognation" Then
        'get a list of all elements within, and store the
        'text in the second one
            Set QuestionFieldLinks = QuestionField.all
            Worksheets("stores").Cells(RowNumber, 5).value = "Dognation"
        End If
       If QuestionField.className = "sl-brand sl-brand-dogjoy" Then
        'get a list of all elements within, and store the
        'text in the second one
            Set QuestionFieldLinks = QuestionField.all
            Worksheets("stores").Cells(RowNumber, 6).value = "Dog Joy"
        End If
                   If QuestionField.className = "sl-brand sl-brand-freshpetselect" Then
        'get a list of all elements within, and store the
        'text in the second one
            Set QuestionFieldLinks = QuestionField.all
            Worksheets("stores").Cells(RowNumber, 7).value = "Freshpet Select"
        End If
                               If QuestionField.className = "sl-brand sl-brand-frozentreats" Then
        'get a list of all elements within, and store the
        'text in the second one
            Set QuestionFieldLinks = QuestionField.all
            Worksheets("stores").Cells(RowNumber, 8).value = "Frozen Treats"
        End If
                               If QuestionField.className = "sl-brand sl-brand-freshbaked" Then
        'get a list of all elements within, and store the
        'text in the second one
            Set QuestionFieldLinks = QuestionField.all
            Worksheets("stores").Cells(RowNumber, 9).value = "Fresh Baked"
        End If

    Next QuestionField
    'go on to next row of worksheet
    RowNumber = RowNumber + 1
    Next

Next zipcell

Set HTML = Nothing


End Sub