Tukukkk

As you may know, I like birds. The Cornell Lab of Ornithology has a tool called eBird where you can submit records of the birds you identified. I recently learned they have an API that I can query, yay! Before this I was just hitting pages and parsing source code.

I've never really queried an API before.

Oh and I normally use late binding, but for this you need these (additional) references

• Microsoft HTML Object Library


• Microsoft Internet Controls


• Microsoft WinHTTP Services, version 5.1


• Microsoft Scripting Runtime

Code

I have two modules - one to get the data from the API and one to create a hierarchy of that data. I used my Comb Sort Multi-dimensional Array on Key (which can be reviewed there instead of here, if need be).

Module PopulateLocations.bas

Option Explicit



Const DELIMITER As String = "},{"



'| */ Documentation for Regions

'| For this API regionType can be subnational2, subnational1, or country (ISO3166)

'| I will refer to subnational1 as majorRegion and subnational2 as minorRegion /*



Public Sub PopulateEbirdRegions()

    Const minorRegionBaseURL As String = "https://ebird.org/ws2.0/ref/region/list/subnational2/"

    Const majorRegionBaseURL As String = "https://ebird.org/ws2.0/ref/region/list/subnational1/"

    Dim countryArray As Variant

    Dim majorArray As Variant

    Dim minorArray As Variant

    countryArray = RetrieveCountries

    majorArray = GetRegions(majorRegionBaseURL, countryArray, MajorSheet)

    minorArray = GetRegions(minorRegionBaseURL, majorArray, MinorSheet, True)



    CreateHierarchy.CreateHierarchy countryArray, majorArray, minorArray

End Sub



Private Function RetrieveCountries() As Variant

    Const COUNTRY_URL As String = "https://ebird.org/ws2.0/ref/region/list/country/world?fmt=csv"

    Dim responseText As String

    Dim response As Variant



    responseText = SendHttpRequest(COUNTRY_URL)

    response = Split(responseText, DELIMITER)



    Dim countryArray() As String

    ReDim countryArray(LBound(response) To UBound(response), 1 To 2)

    Dim index As Long

    For index = LBound(response) To UBound(response)

        countryArray(index, 1) = ExtractCode(response(index))

        countryArray(index, 2) = ExtractName(response(index))

    Next



    countryArray(UBound(countryArray), 2) = Left$(countryArray(UBound(countryArray), 2), Len(countryArray(UBound(countryArray), 2)) - 2)



    WriteToSheet countryArray, countrySheet, "Country Code", "Country"

    RetrieveCountries = countryArray

End Function



Private Function GetRegions(ByVal baseRegionURL As String, ByVal sourceArray As Variant, ByVal targetSheet As Worksheet, Optional ByVal isMinor As Boolean = False) As Variant

    Dim fileType As String

    fileType = ".json"



    Dim subNationalValue As String

    Dim responseText As String

    Dim targetURL As String

    Dim index As Long

    index = 1

    Dim resultIndex As Long

    resultIndex = index



    Dim resultArray() As String

    ReDim resultArray(LBound(sourceArray) To UBound(sourceArray), 1 To 2)



    For index = LBound(sourceArray) To UBound(sourceArray)

        subNationalValue = sourceArray(index, 1)

        targetURL = baseRegionURL & subNationalValue & fileType

        responseText = SendHttpRequest(targetURL)



        If isMinor Then

            If Not responseText = "" Then

                resultArray(resultIndex, 1) = subNationalValue

                resultArray(resultIndex, 2) = responseText

                resultIndex = resultIndex + 1

            End If

        Else

            resultArray(index, 1) = sourceArray(index, 1)

            resultArray(index, 2) = responseText

        End If

    Next



    GetRegions = CleanSource(resultArray, targetSheet)

End Function





Private Function CleanSource(ByVal sourceArray As Variant, ByVal targetSheet As Worksheet) As Variant

    Const FIRST_HEADER As String = "Region Code"

    Const SECOND_HEADER As String = "Region Name"

    Dim cleanIndex As Long

    cleanIndex = 1

    Dim index As Long

    Dim sourceIndex As Long

    Dim response As Variant

    Dim cleanArray() As String

    ReDim cleanArray(1 To 10000, 1 To 2) 'I would like to not hard-code this, but it's not variable in itself, but variable across queries



    For sourceIndex = LBound(sourceArray) To UBound(sourceArray)

        If sourceArray(sourceIndex, 2) <> "" Then

            response = Split(sourceArray(sourceIndex, 2), DELIMITER)

            For index = LBound(response) To UBound(response)

                cleanArray(cleanIndex, 1) = ExtractCode(response(index))

                cleanArray(cleanIndex, 2) = ExtractName(response(index))

                cleanIndex = cleanIndex + 1

            Next

        End If

    Next



    Dim returnArray() As String

    ReDim returnArray(1 To cleanIndex - 1, 1 To 2)

    For index = 1 To UBound(returnArray)

        returnArray(index, 1) = cleanArray(index, 1)

        returnArray(index, 2) = cleanArray(index, 2)

    Next



    WriteToSheet returnArray, targetSheet, FIRST_HEADER, SECOND_HEADER

    CleanSource = returnArray

End Function



Private Function SendHttpRequest(ByVal targetURL As String) As String

    Const API_KEY As String = ""

    Const API_REQUEST_HEADER As String = "X-eBirdApiToken"

    Dim httpRequest As WinHttp.WinHttpRequest

    Set httpRequest = New WinHttp.WinHttpRequest

    httpRequest.Open "GET", targetURL

    httpRequest.setRequestHeader API_REQUEST_HEADER, API_KEY

    httpRequest.send

    SendHttpRequest = httpRequest.responseText

End Function



Private Function ExtractCode(ByVal targetString As String) As String

    ExtractCode = Mid$(targetString, InStr(1, targetString, "code") + 7, InStr((InStr(1, targetString, "code") + 7), targetString, ",") - InStr(1, targetString, "code") - 8)

End Function



Private Function ExtractName(ByVal targetString As String) As String

    ExtractName = Mid$(targetString, InStrRev(targetString, ":") + 2, Len(targetString) - InStrRev(targetString, ":") - 2)

End Function



Private Sub WriteToSheet(ByVal valueArray As Variant, ByVal targetSheet As Worksheet, ByVal firstHeader As String, ByVal secondHeader As String)

    Const FIND_STRING As String = "}"

    targetSheet.Cells(1, 1).Value = firstHeader

    targetSheet.Cells(1, 2).Value = secondHeader

    CombSortArray valueArray, 2

    Dim printRange As Range

    Set printRange = targetSheet.Range(targetSheet.Cells(2, 1), targetSheet.Cells(UBound(valueArray) + 2, 2))

    printRange.Value = valueArray

    printRange.Replace What:=Chr$(34) & FIND_STRING, Replacement:=vbNullString



End Sub



Private Sub CombSortArray(ByRef dataArray As Variant, Optional ByVal numberOfColumns As Long = 1, Optional ByVal sortKeyColumn As Long = 1, Optional ByVal sortAscending As Boolean = True)

    'https://codereview.stackexchange.com/questions/155640/comb-sort-multi-dimensional-array-on-key

    Const SHRINK As Double = 1.3

    Dim initialSize As Long

    initialSize = UBound(dataArray, 1)

    Dim gap As Long

    gap = initialSize

    Dim index As Long

    Dim isSorted As Boolean



    Do While gap > 1 And Not isSorted

        gap = Int(gap / SHRINK)

        If gap > 1 Then

            isSorted = False

        Else

            gap = 1

            isSorted = True

        End If

        index = 1

        Do While index + gap <= initialSize

            If sortAscending Then

                If dataArray(index, sortKeyColumn) > dataArray(index + gap, sortKeyColumn) Then

                    SwapElements dataArray, numberOfColumns, index, index + gap

                    isSorted = False

                End If

            Else

                If dataArray(index, sortKeyColumn) < dataArray(index + gap, sortKeyColumn) Then

                    SwapElements dataArray, numberOfColumns, index, index + gap

                    isSorted = False

                End If

            End If

            index = index + 1

        Loop

    Loop



End Sub

Private Sub SwapElements(ByRef dataArray As Variant, ByVal numberOfColumns As Long, ByVal i As Long, ByVal j As Long)

    Dim temporaryHolder As Variant

    Dim index As Long

    For index = 1 To numberOfColumns

        temporaryHolder = dataArray(i, index)

        dataArray(i, index) = dataArray(j, index)

        dataArray(j, index) = temporaryHolder

    Next

End Sub

Then this module passes the arrays to

Module CreateHierarchy.bas

Option Explicit

Public Sub CreateHierarchy(ByVal countries As Variant, ByVal majorRegions As Variant, ByVal minorRegions As Variant)

    Application.ScreenUpdating = False

    Dim countryIndex As Long

    Dim majorIndex As Long

    Dim minorIndex As Long

    Dim currentRow As Long

    currentRow = 2

    Dim country As String

    Dim region As String

    Dim subRegion As String

    Dim targetSheet As Worksheet

    Set targetSheet = HierarchyTest



    minorIndex = 2

    majorIndex = 2



    For countryIndex = LBound(countries) + 1 To UBound(countries)

        If Not IsEmpty(targetSheet.Cells(currentRow, 1)) _

        Or Not IsEmpty(targetSheet.Cells(currentRow, 3)) _

        Or Not IsEmpty(targetSheet.Cells(currentRow, 5)) Then

            currentRow = currentRow + 1

        End If



        country = countries(countryIndex, 1)

        targetSheet.Cells(currentRow, 1).Value = country

        targetSheet.Cells(currentRow, 2).Value = countries(countryIndex, 2)

        For majorIndex = majorIndex To UBound(majorRegions)

            region = Left$(majorRegions(majorIndex, 1), 2)



            If StrComp(country, region, vbTextCompare) = 0 Then

                region = majorRegions(majorIndex, 1)

                targetSheet.Cells(currentRow, 3).Value = region

                targetSheet.Cells(currentRow, 4).Value = majorRegions(majorIndex, 2)



                For minorIndex = minorIndex To UBound(minorRegions)

                    subRegion = Left$(minorRegions(minorIndex, 1), Len(region))

                    If StrComp(region, subRegion, vbTextCompare) = 0 Then

                        targetSheet.Cells(currentRow, 5).Value = minorRegions(minorIndex, 1)

                        targetSheet.Cells(currentRow, 6).Value = minorRegions(minorIndex, 2)

                        currentRow = currentRow + 1

                    ElseIf StrComp(region, subRegion, vbTextCompare) = -1 Then

                        GoTo skip

                    End If

                Next

            currentRow = currentRow + 1

            ElseIf StrComp(country, region, vbTextCompare) = -1 Then

                GoTo jump

            End If

skip:

        currentRow = currentRow + 1

        Next

jump:



    Next



   Application.ScreenUpdating = True

End Sub

I'm not at all happy with this hierarchy procedure, but it does its job. I'm sure there's a more clever way to do it, but I'm embarrassed about how long it took me to write this junk. If you point out I have three for loops with two ifs in them and make fun of me - I deserve it.

Substitute Code

Because I doubt you have an API key, I've made the raw data available and you can alter the Hierarchy module so it doesn't require arguments to execute:

Public Sub CreateHierarchy()

    Application.ScreenUpdating = False



    Dim countries As Variant

    Dim majorRegions As Variant

    Dim minorRegions As Variant

    countries = RetrieveData(countrySheet)

    majorRegions = RetrieveData(MajorSheet)

    minorRegions = RetrieveData(MinorSheet)



...



End Sub



Private Function RetrieveData(ByVal targetSheet As Worksheet) As Variant

    Dim lastRow As Long

    lastRow = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Row

    Dim dataRange As Range

    Set dataRange = targetSheet.Range(targetSheet.Cells(1, 1), targetSheet.Cells(lastRow, 2))

    RetrieveData = dataRange

End Function

Example return text from SendHTTPRequest

This is (some of) the raw data I get and parse, in case there's a better way to do that -

Country

[{"code":"AF","name":"Afghanistan"},{"code":"AL","name":"Albania"},{"code":"DZ","name":"Algeria"},{"code":"AS","name":"American Samoa"},{"code":"AD","name":"Andorra"},{"code":"AO","name":"Angola"},{"code":"AI","name":"Anguilla"},{"code":"AQ","name":"Antarctica"},{"code":"AG","name":"Antigua and Barbuda"},{"code":"AR","name":"Argentina"},{"code":"AM","name":"Armenia"},{"code":"AW","name":"Aruba"},{"code":"AC","name":"Ashmore and Cartier Islands"},{"code":"ZM","name":"Zambia"},{"code":"ZW","name":"Zimbabwe"}]

Major Region

[{"code":"AF-BDS","name":"Badakhshan"},{"code":"AF-BDG","name":"Badghis"},{"code":"AF-BGL","name":"Baghlan"},{"code":"AF-BAL","name":"Balkh"},{"code":"AF-BAM","name":"Bamian"},{"code":"AF-DAY","name":"Daykondi"},{"code":"AF-FRA","name":"Farah"},{"code":"AF-FYB","name":"Faryab"},{"code":"AF-GHA","name":"Ghazni"},{"code":"AF-GHO","name":"Ghowr"},{"code":"AF-HEL","name":"Helmand"},{"code":"AF-HER","name":"Herat"},{"code":"AF-JOW","name":"Jowzjan"},{"code":"AF-KAB","name":"Kabol"},{"code":"AF-KAN","name":"Kandahar"},{"code":"AF-KAP","name":"Kapisa"},{"code":"AF-KHO","name":"Khowst"},{"code":"AF-KNR","name":"Konar"},{"code":"AF-KDZ","name":"Kondoz"},{"code":"AF-LAG","name":"Laghman"},{"code":"AF-LOW","name":"Lowgar"},{"code":"AF-NAN","name":"Nangarhar"},{"code":"AF-NIM","name":"Nimruz"},{"code":"AF-NUR","name":"Nurestan"},{"code":"AF-ORU","name":"Oruzgan"},{"code":"AF-PIA","name":"Paktia"},{"code":"AF-PKA","name":"Paktika"},{"code":"AF-PAN","name":"Panjshir"},{"code":"AF-PAR","name":"Parwan"},{"code":"AF-SAM","name":"Samangan"},{"code":"AF-SAR","name":"Sar-e Pol"},{"code":"AF-TAK","name":"Takhar"},{"code":"AF-WAR","name":"Wardak"},{"code":"AF-ZAB","name":"Zabol"}]

Minor Region

[{"code":"AR-B-AA","name":"Adolfo Alsina"},{"code":"AR-B-AC","name":"Adolfo Gonzales Chaves"},{"code":"AR-B-AL","name":"Alberti"},{"code":"AR-B-AB","name":"Almirante Brown"},{"code":"AR-B-AM","name":"Ameghino"},{"code":"AR-B-BM","name":"Arrecifes"},{"code":"AR-B-AV","name":"Avellaneda"},{"code":"AR-B-AY","name":"Ayacucho"},{"code":"AR-B-AZ","name":"Azul"},{"code":"AR-B-BB","name":"Bahía Blanca"},{"code":"AR-B-BC","name":"Balcarce"},{"code":"AR-B-BD","name":"Baradero"},{"code":"AR-B-BJ","name":"Benito Juárez"},{"code":"AR-B-BZ","name":"Berazategui"},{"code":"AR-B-BS","name":"Berisso"},{"code":"AR-B-BO","name":"Bolívar"},{"code":"AR-B-BG","name":"Bragado"},{"code":"AR-B-BR","name":"Brandsen"},{"code":"AR-B-CM","name":"Campana"},{"code":"AR-B-CS","name":"Capitán Sarmiento"},{"code":"AR-B-CC","name":"Carlos Casares"},{"code":"AR-B-CT","name":"Carlos Tejedor"},{"code":"AR-B-CA","name":"Carmen de Areco"},{"code":"AR-B-CI","name":"Castelli"},{"code":"AR-B-CL","name":"Cañuelas"},{"code":"AR-B-CB","name":"Chacabuco"},{"code":"AR-B-CH","name":"Chascomús"},{"code":"AR-B-CV","name":"Chivilcoy"},{"code":"AR-B-CO","name":"Colón"},{"code":"AR-B-CD","name":"Coronel Dorrego"},{"code":"AR-B-CP","name":"Coronel Pringles"},{"code":"AR-B-CE","name":"Coronel Suárez"},{"code":"AR-B-CR","name":"Coronel de Marina Leonardo Rosales"},{"code":"AR-B-DA","name":"Daireaux"},{"code":"AR-B-DO","name":"Dolores"},{"code":"AR-B-EN","name":"Ensenada"},{"code":"AR-B-ES","name":"Escobar"},{"code":"AR-B-EB","name":"Esteban Echeverría"},{"code":"AR-B-EC","name":"Exaltación de la Cruz"},{"code":"AR-B-FC","name":"Florencio Varela"},{"code":"AR-B-GD","name":"General Alvarado"},{"code":"AR-B-GA","name":"General Alvear"},{"code":"AR-B-GE","name":"General Arenales"},{"code":"AR-B-GB","name":"General Belgrano"},{"code":"AR-B-GG","name":"General Guido"},{"code":"AR-B-GJ","name":"General Juan Madariaga"},{"code":"AR-B-GM","name":"General La Madrid"},{"code":"AR-B-GH","name":"General Las Heras"},{"code":"AR-B-GL","name":"General Lavalle"},{"code":"AR-B-GZ","name":"General Paz"},{"code":"AR-B-GI","name":"General Pinto"},{"code":"AR-B-GP","name":"General Pueyrredón"},{"code":"AR-B-GR","name":"General Rodríguez"},{"code":"AR-B-GN","name":"General San Martín"},{"code":"AR-B-GS","name":"General Sarmiento"},{"code":"AR-B-GT","name":"General Viamonte"},{"code":"AR-B-GV","name":"General Villegas"},{"code":"AR-B-GU","name":"Guaminí"},{"code":"AR-B-HY","name":"Hipólito Yrigoyen"},{"code":"AR-B-JU","name":"Junín"},{"code":"AR-B-LC","name":"La Costa"},{"code":"AR-B-LM","name":"La Matanza"},{"code":"AR-B-LT","name":"La Plata"},{"code":"AR-B-LS","name":"Lanús"},{"code":"AR-B-LR","name":"Laprida"},{"code":"AR-B-LF","name":"Las Flores"},{"code":"AR-B-LA","name":"Leandro N. Alem"},{"code":"AR-B-LI","name":"Lincoln"},{"code":"AR-B-LO","name":"Lobería"},{"code":"AR-B-LB","name":"Lobos"},{"code":"AR-B-LZ","name":"Lomas de Zamora"},{"code":"AR-B-LU","name":"Luján"},{"code":"AR-B-ML","name":"Magdalena"},{"code":"AR-B-MA","name":"Maipú"},{"code":"AR-B-MC","name":"Mar Chiquita"},{"code":"AR-B-MP","name":"Marcos Paz"},{"code":"AR-B-MD","name":"Mercedes"},{"code":"AR-B-ME","name":"Merlo"},{"code":"AR-B-MT","name":"Monte"},{"code":"AR-B-MH","name":"Monte Hermoso"},{"code":"AR-B-MR","name":"Moreno"},{"code":"AR-B-MN","name":"Morón"},{"code":"AR-B-NA","name":"Navarro"},{"code":"AR-B-NE","name":"Necochea"},{"code":"AR-B-NJ","name":"Nueve de Julio"},{"code":"AR-B-OL","name":"Olavarría"},{"code":"AR-B-PA","name":"Patagones"},{"code":"AR-B-PJ","name":"Pehuajó"},{"code":"AR-B-PE","name":"Pellegrini"},{"code":"AR-B-PG","name":"Pergamino"},{"code":"AR-B-PL","name":"Pila"},{"code":"AR-B-PX","name":"Pilar"},{"code":"AR-B-PI","name":"Pinamar"},{"code":"AR-B-PU","name":"Puán"},{"code":"AR-B-QU","name":"Quilmes"},{"code":"AR-B-RM","name":"Ramallo"},{"code":"AR-B-RU","name":"Rauch"},{"code":"AR-B-RI","name":"Rivadavia"},{"code":"AR-B-RO","name":"Rojas"},{"code":"AR-B-RP","name":"Roque Pérez"},{"code":"AR-B-SD","name":"Saavedra"},{"code":"AR-B-SL","name":"Saladillo"},{"code":"AR-B-SQ","name":"Salliqueló"},{"code":"AR-B-ST","name":"Salto"},{"code":"AR-B-SG","name":"San Andrés de Giles"},{"code":"AR-B-SA","name":"San Antonio de Areco"},{"code":"AR-B-SC","name":"San Cayetano"},{"code":"AR-B-SF","name":"San Fernando Partido"},{"code":"AR-B-SI","name":"San Isidro"},{"code":"AR-B-SN","name":"San Nicolás"},{"code":"AR-B-SP","name":"San Pedro"},{"code":"AR-B-SE","name":"San Vicente"},{"code":"AR-B-SU","name":"Suipacha"},{"code":"AR-B-TD","name":"Tandil"},{"code":"AR-B-TP","name":"Tapalqué"},{"code":"AR-B-TI","name":"Tigre"},{"code":"AR-B-TO","name":"Tordillo"},{"code":"AR-B-TQ","name":"Tornquist"},{"code":"AR-B-TR","name":"Trenque Lauquen"},{"code":"AR-B-TA","name":"Tres Arroyos"},{"code":"AR-B-TL","name":"Tres Lomas"},{"code":"AR-B-TF","name":"Tres de Febrero"},{"code":"AR-B-VM","name":"Veinticinco de Mayo"},{"code":"AR-B-VL","name":"Vicente López"},{"code":"AR-B-VG","name":"Villa Gesell"},{"code":"AR-B-VI","name":"Villarino"},{"code":"AR-B-ZA","name":"Zárate"}]

The OP has got the web scraping very close. But there are a couple of things that need to be tweaked.

WriteToSheet:Sub

Case in point WriteToSheet. RetrieveCountries pass a Base 0 array to it and CleanSource passes a Base 1 array. There seems to be no attempt to adjust for the differences. It is causing the target ranges for both and to be 1 row larger then the data array. This is causing the #N/A in the last row of both the MinorSheet and the MajorSheet.

The cells should also be cleared before the data in added.

Here is an easy fix:

Set printRange = targetSheet.Range("A2").Resize(UBound(valueArray) - LBound(valueArray) + 1, 2)

This line tells me that the technique for parsing the JSON is incomplete:

printRange.Replace What:=Chr$(34) & FIND_STRING, Replacement:=vbNullString

RetrieveCountries:Function

Here is another attempt to jerry-rig the code because the parsing isn't quite right.

countryArray(UBound(countryArray), 2) = Left$(countryArray(UBound(countryArray), 2), Len(countryArray(UBound(countryArray), 2)) - 2)

Adjusting the last element in an array after the value has been assigned to it, feels ... I don't know tacky??

I would probably strinp the ends of the responseText first.

 responseText = Mid(responseText,4,len(responseText)-6)

IMO. writing a Function to process the JSON responseText and a Sub to merge arrays would greatly simplify the code.

Function JSONCodeNameToArray(responseText As String)  as Variant()



Sub MergeJSONArrays(Arr1 as Variant(), Arr2 As Variant())

I think that it would be even easier to pass a Dictionary with the responseText. This would make adding the "Sub Regions" really simple.

Sub AddJSON(ByRef responseText As String, ByRef Dic As Object)

Addendum

CreateHierarchy:Class

I am not going to examine this class but instead am going to show an easier way to create the hierarchy using sequel. To simplify writing the SQL I pasted the worksheets from ebird.xlsm into an Access database. I then used the query designer to write and test the sql. The query can also be modify to ran against ebird.xlsm. You will have to enclose the worksheet names followed by $ in brackets(e.g [SubNat2Sheet$] .

SELECT countrySheet.[Country Code], countrySheet.Country, SubNat1Sheet.[Region Code], SubNat1Sheet.[Region Name]

FROM countrySheet INNER JOIN SubNat1Sheet ON countrySheet.[Country Code] = Left(SubNat1Sheet.[Region Code],2)

UNION ALL

SELECT countrySheet.[Country Code], countrySheet.Country, SubNat2Sheet.[Region Code], SubNat2Sheet.[Region Name]

FROM countrySheet INNER JOIN SubNat2Sheet ON countrySheet.[Country Code] = Left(SubNat2Sheet.[Region Code],2)

My first answer was a review of the OP's post. This answer is an alternate approach.

The my first solution and OP's approach took about 775 seconds to make 3936 synchronized WinHttp.WinHttpRequest requests. Using asynchronous MSXML2.ServerXMLHTTP requests with a callback class completes the same 3936 requests to 16 seconds.

UpdateRegions:Sub

Public Sub UpdateRegions()

    Dim StartTime As Long: StartTime = Timer

    Dim Target As Range

    Dim Controller As EBirdController

    Set Controller = New EBirdController

    Controller.Initialize



    While Not Controller.ReadyStateComplete

        DoEvents

    Wend



    With Worksheets("Results")

        .Cells.Clear

        With .Range("A1").Resize(1, 6)

            .Value = Array("Contry Code", "Country", "Region Code", "Region", "Sub Region Code", "Sub Region")

            .Font.Bold = True

            .Interior.Color = 6299648

            .Font.ThemeColor = xlThemeColorDark1

        End With

        Set Target = Controller.CopyToRange(.Range("A2"))



        .Sort.SortFields.Clear

        .Sort.SortFields.Add Key:=Target.Columns("B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

        .Sort.SortFields.Add Key:=Target.Columns("D"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

        .Sort.SortFields.Add Key:=Target.Columns("F"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

        With .Sort

            .SetRange Target.Resize(Target.Rows.Count + 1).Offset(-1)

            .Header = xlYes

            .MatchCase = False

            .Orientation = xlTopToBottom

            .SortMethod = xlPinYin

            .Apply

        End With

        .Columns.AutoFit

    End With

    MsgBox "Run Time in Seconds: " & Round(Timer - StartTime, 2)

End Sub

EBirdController:Class

Option Explicit

Private Const COUNTRY_URL As String = "https://ebird.org/ws2.0/ref/region/list/country/world.csv"

Private Const REGION_BASE_URL As String = "https://ebird.org/ws2.0/ref/region/list/subnational"

Private Const MAX_CONNECTIONS As Long = 50

Private Type Members

    CompletedRequestsList As Object

    OpenRequestsList As Object

    RequestStack As Object

End Type

Private m As Members



Private Enum DataFields

    dfCode = 1

    dfName

End Enum



Private Sub Class_Initialize()

    Set m.CompletedRequestsList = CreateObject("System.Collections.ArrayList")

    Set m.OpenRequestsList = CreateObject("System.Collections.ArrayList")

    Set m.RequestStack = CreateObject("System.Collections.Stack")

End Sub



Private Function getRequestData(Request As EBirdRegionalRequest) As String()

    Dim values() As String, results() As String

    Dim index As Long, r As Long

    values = Split(Request.getResponseText, Chr(10))



    If UBound(values) > 1 Then ReDim results(1 To UBound(values) - 1, 1 To 2) Else ReDim results(0 To 0, 1 To 2)

    For r = 1 To UBound(values) - 1

        index = InStr(values(r), ",")

        results(r, dfCode) = Left(values(r), index - 1)

        results(r, dfName) = Right(values(r), Len(values(r)) - index)

    Next



    getRequestData = results

End Function



Public Sub Initialize()

    AddRequest COUNTRY_URL

    ProcessRequestStack

End Sub



Public Sub ReadyStateChangeHandler(Request As EBirdRegionalRequest)

    Dim data() As String

    Dim index As Long, r As Long

    Dim URL As String

    m.OpenRequestsList.Remove Request.URL

    data = getRequestData(Request)



    If UBound(data) = 0 Then  'And Request.URL Like REGION_BASE_URL & "2*"

        m.CompletedRequestsList.Add Array(Request.countryCode, Request.country, Request.regionCode, Request.region, data(r, dfCode), data(r, dfName))

    Else

        For r = 1 To UBound(data)

            If Request.URL = COUNTRY_URL Then

                URL = REGION_BASE_URL & "1/" & data(r, dfCode) & ".csv"

                AddRequest URL, data(r, dfCode), data(r, dfName)

            ElseIf Request.URL Like REGION_BASE_URL & "1/*" Then

                URL = REGION_BASE_URL & "2/" & data(r, dfCode) & ".csv"

                AddRequest URL, Request.countryCode, Request.country, data(r, dfCode), data(r, dfName)

            Else

                m.CompletedRequestsList.Add Array(Request.countryCode, Request.country, Request.regionCode, Request.region, data(r, dfCode), data(r, dfName))

            End If

        Next

    End If

    Set Request = Nothing

    ProcessRequestStack

End Sub



Private Sub AddRequest(URL As String, Optional countryCode As String, Optional country As String, Optional regionCode As String, Optional region As String)

    Dim Request As New EBirdRegionalRequest

    With Request

        .URL = URL

        .countryCode = countryCode

        .country = country

        .regionCode = regionCode

        .region = region

    End With

    m.RequestStack.Push Request

End Sub



Private Sub ProcessRequestStack()

    Dim Request As EBirdRegionalRequest

    If m.OpenRequestsList.Count = MAX_CONNECTIONS Then Stop

    Do Until m.OpenRequestsList.Count = MAX_CONNECTIONS Or m.RequestStack.Count = 0

        Set Request = m.RequestStack.Pop

        m.OpenRequestsList.Add Request.URL

        Request.setCallback Me

    Loop

End Sub



Public Function CopyToRange(Target As Range) As Range

    Dim results() As Variant

    If m.CompletedRequestsList.Count > 0 Then

        results = m.CompletedRequestsList.ToArray

        results = Application.Transpose(results)

        results = Application.Transpose(results)

        Set Target = Target.Resize(UBound(results), UBound(results, 2))

        Target.Value = results

    End If

    Set CopyToRange = Target

End Function



Public Property Get ReadyStateComplete() As Boolean

    ReadyStateComplete = m.OpenRequestsList.Count = 0 And m.RequestStack.Count = 0

End Property

EBirdRegionalRequest:Class

Option Explicit

Private Const API_KEY As String = "Sign up and get your own key..lol"

Private Const API_REQUEST_HEADER As String = "X-eBirdApiToken"

Private Type Members

    Controller As EBirdController

    responseText As String

    XMLHttpReq As Object

End Type

Private m As Members



Public country As String

Public countryCode As String

Public region As String

Public regionCode As String

Public subRegion As String

Public subregionCode As String

Public URL As String



Function getResponseText() As String

    getResponseText = m.XMLHttpReq.responseText

End Function



Public Sub ReadyStateChangeHandler()

Attribute ReadyStateChangeHandler.VB_UserMemId = 0

    If m.XMLHttpReq.readyState = 4 Then

        m.Controller.ReadyStateChangeHandler Me

    End If

End Sub



Public Sub setCallback(Controller As EBirdController)

    Set m.Controller = Controller

    Set m.XMLHttpReq = CreateObject("MSXML2.ServerXMLHTTP")

    With m.XMLHttpReq

        .onreadystatechange = Me

        .Open "GET", URL, True

        .setRequestHeader API_REQUEST_HEADER, API_KEY

        .Send

    End With

End Sub

References

http://www.tushar-mehta.com/publish_train/xl_vba_cases/vba_web_pages_services/#_Toc173749363
https://msdn.microsoft.com/en-us/library/ms757030.aspx
http://dailydoseofexcel.com/archives/2006/10/09/async-xmlhttp-calls/
https://github.com/driverdan/node-XMLHttpRequest/blob/master/lib/XMLHttpRequest.js#L358
https://codingislove.com/http-requests-excel-vba/

Max Connections

There is no noticeable difference between having 50 or 100 open connections at one time. Increasing MAX_CONNECTIONS to 250 causes the code not to complete. For some reason this increases the callback time and causes a number of requests not to be returned to the Controller.

Edits

I update the code to late binding. This is no longer a need for any "External Library References".