加速vba抓取的方法POST请求

如何解决加速vba抓取的方法POST请求

我使用 vba 和 JSON Parser 库制作了一个网页抓取工具。 我的代码如下，运行正常。

Sub Setcustoms()
Dim JSON As Object
Dim ws As Worksheet,results(),i As Long,s As String
Dim shipvalue As String,custom As String,MyURL As String
Dim BL As String,returnshipvalue As String
Dim a,b As Variant
Dim mytext,finaltext As String
Dim myvalue As Object
Dim country() As String
Dim year As String



country = Split("NL,DE,MY,US,VN,UA,ID,JP,CN,CL,CA,TH,PL,RU,PH",",")
'country = Split("MY,VN",")
Dim port() As String


port = Split("KRKAN,KRKUV,KRTSN,KRPUS,KRYMH,KRINC,KRPTK,KRKPO,KRKCN,KRBNP,KRUSN",")
'port = Split("KRKAN,KRKUV",")


Application.ScreenUpdating = False


i = 2
For Each a In country
    For Each b In port
        With CreateObject("MSXML2.XMLHTTP")
            .Open "POST","https://www.bandtrass.or.kr/customs/total.do",False
            .setRequestHeader "Accept","application/json,text/javascript,*/*; q=0.01"
            .setRequestHeader "User-Agent","Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML,like Gecko) Chrome/87.0.4280.66 Safari/537.36"
            .setRequestHeader "Content-Type","application/x-www-form-urlencoded; charset=UTF-8"
            .setRequestHeader "Accept-Encoding","gzip,deflate,br"
            .send "SELECT_DIV1=PORT_DIV&GODS_TYPE=H&ECONO_TYPE=undefined&PORT_TYPE=B&LOCATION_TYPE=undefined&FILTER1_GODS_UNIT=&SELECT_DIV2=NATN_DIV&FILTER2_GODS_UNIT=&SELECT_DIV3=GODS_DIV&FILTER3_GODS_UNIT=10&POP_TABLE=&COL_NAME=&EXCEL_LOG=&MENU_CODE=CUS00301_POP&EXCEL_SUBJECT=&SelectCd3=4401310000" + _
            "&SelectCd1=" & b & "&SelectCd2=" & a
            
            mytext = Right(.responseText,Len(.responseText) - 44)
            finaltext = Replace(Left(mytext,Len(mytext) - 2),"\","")
            Set JSON = JsonConverter.ParseJson(finaltext)
            For Each myvalue In JSON
                If Len(myvalue("BASE_DATE")) = 5 Then
                    year = myvalue("BASE_DATE")
                Else
                    If myvalue("IM_WGHT") <> "" Then
                        Cells(i,2).Value = DateSerial(CInt(Left(year,4)),CInt(Left(LTrim(myvalue("BASE_DATE")),2)) + 1,0)
                        Cells(i,3).Value = a
                        Cells(i,4).Value = b
                        Cells(i,5).Value = myvalue("IM_WGHT") / 1000
                        If myvalue("IM_WGHT") <> 0 Then
                            Cells(i,6).Value = myvalue("IM_AMT") * 1000 / myvalue("IM_WGHT")
                            i = i + 1
                        Else
                        End If
                    Else
                    End If
                End If
            Next
        End With
    Next
Next
Application.ScreenUpdating = True

结束子

我唯一的问题是刮刀需要大约 10 分钟才能完成。 我真的很想加快这个过程，因为我将每月更新数据。 另一个可行的选择是，我可以通过最近几个月的时间进行抓取，但在这种情况下，我必须重写整个代码。

是否有任何可能的方法来加快进程？ 谢谢。