Need to use VBA-JSON to pull data from different URLs where the numbers in the URL change
I am collecting data from a crypto-game that I play. I am already able to parse data using the site’s API for just my “mons”. I am trying to to collect the same data for ALL of the mons in the game. The API lets you pull data for 99 mons at a time (caps at 99 at a time). There are approx. 48,000 mons in existence and that number continues to go up. Each mon has an ID number (1 being the first ever caught and n+1 for each one after that).
This is the link to access the data for mons 1-99: https://www.etheremon.com/api/monster/get_data?monster_ids=1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99
I need to pull data for mons 1-99, then 100-198, then 199-297 and so on all the way to 48000.
From each mon I want to collect the ID Number, “class_name”, “total_level”, “perfect_rate”, “create_index” (which are all dicts) and most importantly I want the “total_battle_stats” (which is an array).
Here is the code I have for pulling all of those variables for just the mons in my inventory (it references a different link), but it already includes the arrangement of how I want it.
I just need those same variables but referencing a bunch of different links, not just one.
Public Sub WriteOutBattleInfo()
Dim headers(), r As Long, i As Long, json As Object, key As Variant, ws As Worksheet, battleStats As Object
Set ws = ThisWorkbook.Worksheets(“Sheet1”)
headers = Array(“Monster #”, “Name”, “Total Level”, “Perfection”, “Catch Number”, “HP”, “PA”, “PD”, “SA”, “SD”, “SPD”)
With CreateObject("MSXML2.XMLHTTP") .Open "GET", "https://www.etheremon.com/api/user/get_my_monster?trainer_address=0x2Fef65e4D69a38bf0dd074079f367CDF176eC0De", False .Send Set json = JsonConverter.ParseJson(.ResponseText)("data")("monsters") 'dictionary of dictionaries End With r = 2 ws.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers For Each key In json.Keys With ws .Cells(r, 1) = key .Cells(r, 2) = json(key)("class_name") .Cells(r, 3) = json(key)("total_level") .Cells(r, 4) = json(key)("perfect_rate") .Cells(r, 5) = json(key)("create_index") Set battleStats = json(key)("total_battle_stats") For i = 1 To battleStats.Count .Cells(r, i + 5) = battleStats.Item(i) Next i End With r = r + 1 Next Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 key:=Range("C2:C110" _ ), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Sheet1").Sort .SetRange Range("A1:K110") .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Selection.Columns.AutoFit
I would like it to look exactly like this: https://imgur.com/a/xPA9T7W
But I want all of the Mons from ID 1 to 48000.
You could use a function to increment the ids to concatenate onto a base url. The site throttles/blocks if you request too quickly/possibly too many times. Check the documentation for any advice on this.
I show how you could retrieve all. I include a test case for 1 to 5 requests (uncomment to get the full number of requests. Note: I give a line, for you to tweak, which allows for adding in a delay every x requests to try and avoid throttling/blocking. It seems likely the number is quite low before this happens.
Later on, you can consider moving this into a class to hold the xmlhttp object and provide it methods such as getItems. Example here.
Option Explicit Public Sub WriteOutBattleInfo() Const BASE_URL As String = " https://www.etheremon.com/api/monster/get_data?monster_ids=" Const END_COUNT As Long = 48000 Const BATCH_SIZE As Long = 99 Dim numberOfRequests As Long, i As Long, j As Long, ids As String Dim headers(), r As Long, json As Object, key As Variant, ws As Worksheet, battleStats As Object Set ws = ThisWorkbook.Worksheets("Sheet1") headers = Array("Monster #", "Name", "Total Level", "Perfection", "Catch Number", "HP", "PA", "PD", "SA", "SD", "SPD") numberOfRequests = Application.WorksheetFunction.RoundDown(END_COUNT / BATCH_SIZE, 0) ids = "1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99" Dim results() ReDim results(1 To END_COUNT, 1 To 11) r = 1 With CreateObject("MSXML2.XMLHTTP") For i = 1 To 5 'numberOfRequests + 1 If i Mod 10 = 0 Then Application.Wait Now + TimeSerial(0, 0, 1) If i > 1 Then ids = IncrementIds(ids, BATCH_SIZE, END_COUNT) .Open "GET", BASE_URL & ids, False .send Set json = JsonConverter.ParseJson(.responseText)("data") For Each key In json.keys results(r, 1) = key results(r, 2) = json(key)("class_name") results(r, 3) = json(key)("total_level") results(r, 4) = json(key)("perfect_rate") results(r, 5) = json(key)("create_index") Set battleStats = json(key)("total_battle_stats") For j = 1 To battleStats.Count results(r, j + 5) = battleStats.item(j) Next j r = r + 1 Next Next End With ws.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers ws.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results End Sub Public Function IncrementIds(ByVal ids As String, ByVal BATCH_SIZE As Long, ByVal END_COUNT) As String Dim i As Long, arrayIds() As String arrayIds = Split(ids, ",") For i = LBound(arrayIds) To UBound(arrayIds) If CLng(arrayIds(i)) + BATCH_SIZE <= END_COUNT Then arrayIds(i) = arrayIds(i) + BATCH_SIZE Else ReDim Preserve arrayIds(0 To i - 1) Exit For End If Next IncrementIds = Join(arrayIds, ",") End Function