Web scraping county, population and median home value from United States postal zip codes.

enter image description here

I switched from using InternetExplorer.Application to New MSXML2.XMLHTTP60. For the first time, I broke code into smaller subs or functions, among other things.

  • This code ran successfully 1 time, with other tests returning only 70-100 records.
  • UsingInternetExplorer.Application, I projected the code to complete in 1H:45M by timing 20 records. With the XML method, I projected 25-30 min as it takes about 5 min to fetch 70-100 records.
  • Excel goes completely blank when running (white screen).

There appears to be several things I can do:

  • Early binding (which I didn't understand how to implement based on the thread)
  • Creating VBScripts to simulate multi-threading; I've not created VBScripts with Excel so this option is taking me a little bit as I try to read and study VBScripts more in depth.
  • Can't seem to find the link, but elsewhere, I read that jumping around would make things slow. According to the thread, I should store all values in an array first, after all values are retrieved, I then should input them into the corresponding cells, instead of retrieving and inputting right away. (I think I can handle this but not sure if anyone has any pointers as to whether this actually works).


'ZipCodeScrape Variables
    Public ZipCodeRange As Range
    Public cell as Variant

'Web Variables
    Public IE As MSXML2.XMLHTTP60
    Public url As String
    Public post As Object
    Public HTML As MSHTML.HTMLDocument
    Public HTMLbody As MSHTML.HTMLbody

Gathering zip codes and using a function to retrieve data

Sub ZipCodeScrape()

    Set IE = New MSXML2.XMLHTTP60
    url = "https://www.unitedstateszipcodes.org/"

    Set ZipCodeRange = Range("C2", Range("C2").End(xlDown))

    Dim TargetElement(1 To 3) As String
        TargetElement(1) = "County:"
        TargetElement(2) = "Population"
        TargetElement(3) = "Median Home Value"
    Dim i As Integer

    For Each cell In ZipCodeRange
        For i = 1 To 3
            cell.Offset(0, i).Value = dataScrape("th", TargetElement(i), "td")
        Next i
    Next cell
End Sub

Here is the function I'm using to retrieve the data

Private Function dataScrape(ByVal TagName As String, Element As String, targetTagName)

    IE.Open "GET", url & cell.Value, False

    While IE.readyState <> 4: DoEvents: Wend

    Set HTML = New MSHTML.HTMLDocument
    Set HTMLbody = HTML.body
    HTMLbody.innerHTML = IE.responseText

        For Each post In HTMLbody.getElementsByTagName(TagName)
            If InStr(post.innerText, Element) > 0 Then
                dataScrape = post.ParentNode.getElementsByTagName(targetTagName)(0).innerText: Exit For
            End If
        Next post

End Function
  • \$\begingroup\$ I forgot to mention that the reason that the WebSite limits you to a certain number of lookups a day. I was reminded of this while testing a VBS Multithreading version of the code. \$\endgroup\$
    – user109261
    Dec 28, 2017 at 14:58
  • \$\begingroup\$ Ah, ok, that makes sense. I tested a lot yesterday, prior and after the code worked. I'm looking over your post now, thank you by the way, and I'll add some questions on the comments. \$\endgroup\$ Dec 28, 2017 at 16:25

1 Answer 1


"5 min to fetch 70-100 records" seems pretty slow. Even though, you are fetching the same URL 3 times per Zip Code, this still seems slow.

    For i = 1 To 3
        cell.Offset(0, i).Value = dataScrape("th", TargetElement(i), "td")
    Next i

Avoid using Global variables whenever possible. Pass the values as parameters instead.

Turning off Application.ScreenUpdating and setting Application.Calculation = xlCalculationManual will speed up the writing the data to the Worksheet.

The code below processed 200 records in 41 seconds.

Refactored Code

Sub ZipCodeScrape()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Const BASE_URL = "https://www.unitedstateszipcodes.org/"
    Dim doc As MSHTML.HTMLDocument, cell As Range

    For Each cell In Range("C2", Range("C2").End(xlDown))
        Set doc = getDocument(BASE_URL & Format(cell.Value, "00000"))
        If Not doc Is Nothing Then
            cell.Offset(0, -2).Value = getPrimaryCity(doc)
            cell.Offset(0, -1).Value = getState(doc)
            cell.Offset(0, 1).Value = getTDByTH(doc, "County: ")
            cell.Offset(0, 2).Value = getTDByTH(doc, "Population")
            cell.Offset(0, 3).Value = getTDByTH(doc, "Median Home Value")
        End If

    Next cell
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Private Function getTDByTH(doc As MSHTML.HTMLDocument, Heading As String) As String
    Dim post As Object
    For Each post In doc.getElementsByTagName("TH")
        If post.innerText = Heading Then
            getTDByTH = post.ParentNode.getElementsByTagName("TD")(0).innerText
            Exit For
        End If
    Next post
End Function

Private Function getPrimaryCity(doc As MSHTML.HTMLDocument) As String
    Dim PrimaryCity As String
    PrimaryCity = getTDByTH(doc, "Primary City:")
    getPrimaryCity = Split(PrimaryCity, ",")(0)
End Function

Private Function getState(doc As MSHTML.HTMLDocument) As String
    Dim PrimaryCity As String
    Dim PrimaryCityArray() As String
    PrimaryCity = getTDByTH(doc, "Primary City:")
    PrimaryCityArray = Split(PrimaryCity, ",")
    getState = Split(PrimaryCityArray(1), " ")(1)
End Function

Private Function getDocument(URL As String) As MSHTML.HTMLDocument
    Dim doc As MSHTML.HTMLDocument
    With New MSXML2.XMLHTTP60
        .Open "GET", URL, False
        If .readyState = 4 And .Status = 200 Then
            Set doc = New MSHTML.HTMLDocument
            doc.body.innerHTML = .responseText
            Set getDocument = doc
            Debug.Print "URL Not Responding:  "; URL, "Ready state: "; .readyState, "HTTP request status: "; .Status
        End If
    End With
End Function

The Multi-threaded VBA that you referred to would be considerably faster.

  • \$\begingroup\$ Ok, I see where I'm sending requests multiple times for the same thing and that will certainly speed things up. I'm having trouble working through the getTDByTD procedure. It's giving me a Compile Error: User-Defined type not defined on the very first line where you define the function "Private Func...". I have the following libraries, Visual Basic for Applications, MS Excel 16.0 Object Library, OLE Automation, MS HTML Object Library, MS Internet Controls and MS XML, v6.0. According to threads online, I shouldn't need anything else. Do you have a library I don't listed on your end? \$\endgroup\$ Dec 28, 2017 at 17:21
  • \$\begingroup\$ Also, on the private functions, the trailing "As String" declaration, what does that do? I assume it returns the entire thing function as a string, but is it necessary? (even if it weren't, I would like to type it out for readability purposes... I'm just curious. \$\endgroup\$ Dec 28, 2017 at 17:32
  • \$\begingroup\$ I'm not sure why you are getting the error. I'm using the same libraries that you have referenced in your code. \$\endgroup\$
    – user109261
    Dec 28, 2017 at 17:39
  • \$\begingroup\$ Ok, it is now fixed. I just copied and pasted your code. Sorry, I probably had some sort of typo, I literally spent the last 30 min trying to research it without first trying to copy the code. \$\endgroup\$ Dec 28, 2017 at 17:40
  • 1
    \$\begingroup\$ It's best to declare the types of your functions and variables whenever possible. It is not only more efficient but it will help catch Type Mismatch errors early. \$\endgroup\$
    – user109261
    Dec 28, 2017 at 17:44

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.