※本ソースコードを利用した際に生じる不具合、不利益などに関して（一財）日本知的財産協会及び筆者は一切の責任を負いません。
※本ファイルのソースコードはCC0で公開します。
※CC0 とは、科学者や教育関係者、アーティスト、その他の著作権保護コンテンツの作者・所有者が、著作権による利益を放棄し、作品を完全にパブリック・ドメインに置くことを可能にするものです。CC0によって、他の人たちは、著作権による制限を受けないで、自由に、作品に機能を追加し、拡張し、再利用することができるようになります。
※https://creativecommons.jp/sciencecommons/aboutcc0/

Sub Sample()

Dim httpObj As Object
Dim tParam, posNum, sDate, eDate, i, j As Integer
Dim vSearchField() As Variant
Dim strResponse, strSheetName, strApplid, strSearch As String

Const RequestURL As String = "https://ped.uspto.gov/api/queries" 'PEDS

strSheetName = "applId" 'サンプル用：対象のシート名は適宜変更ください
strResponse = ""

'サンプル用：出願番号の入力セルはB2(2,2)に固定
'出願番号の"/"と","は不要なので整形
strApplid = Sheets(strSheetName).Cells(2, 2).Value
strApplid = Replace(strApplid, "/", "")
strApplid = Replace(strApplid, ",", "")

'クエリ作成（出願番号(applId)をキーに検索）
'API Tutorial(https://ped.uspto.gov/peds/#/apiDocumentation)のサンプルもご参照ください。
tParam = "{""searchText"":""applId:(" & strApplid & ")"",""fl"":""*"",""mm"":""100%"",""df"":""patentTitle"", ""qf"":""appEarlyPubNumber applId appLocation appType appStatus_txt appConfrNumber appCustNumber appGrpArtNumber appCls appSubCls appEntityStatus_txt patentNumber patentTitle primaryInventor firstNamedApplicant appExamName appExamPrefrdName appAttrDockNumber appPCTNumber appIntlPubNumber wipoEarlyPubNumber pctAppType firstInventorFile appClsSubCls rankAndInventorsList"", ""facet"":""false"",""sort"":""applId asc"",""start"":""0""}"

Set httpObj = CreateObject("MSXML2.XMLHTTP")
httpObj.Open "POST", RequestURL, False
httpObj.setRequestHeader "Content-Type", "application/json" '現在USPTOの対応はJSON形式のみ
httpObj.Send (tParam)

'ステータスチェック
Do
    If httpObj.readyState = 4 Then '"READYSTATE_COMPLETE"
        Exit Do
    End If
    DoEvents
Loop

'成功ならシートに表示
If httpObj.Status = "200" Then
    
    'Data Mapping(https://ped.uspto.gov/peds/#/apiDocumentation)を参考に抽出したい要素のFieldを指定
    vSearchField = Array("firstNamedApplicant", "appFilingDate", "appStatus", "patentNumber", "appClsSubCls", "appGrpArtNumber", "appExamName")
    
    strResponse = httpObj.ResponseText
    
    'サンプル用：JSONパーサではなく、文字列操作で当該要素の内容を抽出。適宜ご変更ください
    For i = 0 To UBound(vSearchField) Step 1
        posNum = InStr(strResponse, vSearchField(i))
        strSearch = Mid(strResponse, posNum + Len(vSearchField(i)) + 3, (InStr(posNum + Len(vSearchField(i)) + 3, strResponse, """") - (posNum + Len(vSearchField(i)) + 3)))
        If vSearchField(i) = "appFilingDate" Then
            strSearch = Left(strSearch, 10)
        End If
        If strSearch = "" Then
            strSearch = "-"
        End If
        Sheets(strSheetName).Cells(3 + i, 2).Value = strSearch
    Next i
    
End If

End Sub