【pleasanter/VBA】エクスポート⑦200件超のデータを出力する方法 Offset

エクセルVBAでプリザンターから情報取得、シリーズ。第7回です。

前回までVBAでエクスポートする基本、絞り込み条件の指定方法、ソートの方法、表示名を出力する方法などをやってきました。

しかしそもそも、テスト用のサイトにはじつは299件のレコードがあるのですが、全出力しても200件までしか出ていませんでした。
なぜか？というと、プリザンターは初期設定のままなにも変更していないのですが、初期値ではApiで取得する件数は200件まで、となるようです。
https://pleasanter.org/manual/faq-api-paging

で、全件出したいですよね。Offsetというのを使うと出せそうなので、やってみたいと思います。

なお、VBAでのエクスポートのやり方、フィルター条件のやりかた、は割愛しますので、前回までの記事を参照してください。

※おことわり
2023年8月時点の情報です。プリザンターのバージョンは 1.3.20.0 です。Google Chrome でやっています。
javascript,html,cssともに初心者です。調べながら、やってみながら、きっとこうすればいいんだ！という感じで書いていますので、間違っている場合、効率的な書き方ではない可能性が大いにあります。間違ってるよ！とか、こうしたほうがいいよ！ということがありましたら、コメント等で教えていただけると大変ありがたいです。

１．使用するサイトの内容
２．キーワードは Offset、TotalCount、PageSize
３．Offsetしてやってみる。
４．TotalCountとpageSizeを利用して全件を出力するコード
５．別解のコード
６．最後に
７.参考記事

１．使用するサイトの内容

前回までと同じです。

299件のデータがあります。

２．キーワードは Offset、TotalCount、PageSize

あれこれ見ていて、キーワードは Offset、TotalCount、Date.Count、PageSize あたりに違いない、とあたりを付けました。

Offset、TotalCount、PageSize についてはプリザンター公式サイトに記載がありました。

FAQ：API で 200 レコードを超えるデータを取得するには。
・概要
複数レコードを取得する際 API からの応答に含まれるレコードの件数は Api.json の PageSize(デフォルトで 200) が最大となります。
Offset を指定するとことで、後続のレコードを取得することができます。

・対応方法
レスポンスの TotalCount が、レスポンスの PageSize を超えている場合、取得できていないレコードが存在します。Offset を追加したリクエストをすることで、後続のレコードを取得します。
・レコード件数の確認
以下のようなリクエストを行うと、レコードの件数の情報が取得できます。
このとき
(開始位置 + 一度に取得できる件数) > 全件
となっているかをチェックすることで、未取得のレコードがあることをコード的に判定できます。
引用元：https://pleasanter.org/manual/faq-api-paging

jsonRequest.Add “Offset”, 200　等として、データの読み込み開始位置をずらせるみたいです。
ためしに以下のコードを実行してイミディエイトウインドウを確認します。

Const myApikey As String = "12345abcde"
       
Dim jsonRequest     As Dictionary
Dim parseResponse   As Dictionary
Dim httpRequest     As Object
    
Set jsonRequest = New Dictionary
jsonRequest.Add "ApiVersion", "1.1"
jsonRequest.Add "ApiKey", myApikey
'offsetに0を指定
jsonRequest.Add "Offset", 0
jsonRequest.Add "View", New Dictionary
jsonRequest("View").Add "ColumnSorterHash", New Dictionary
jsonRequest("View")("ColumnSorterHash").Add "ResultId", "asc"
    
Set httpRequest = CreateObject("msxml2.xmlhttp")
    
httpRequest.Open "POST", "http://localhost/api/items/426/get"
httpRequest.setRequestHeader "Content-Type", "application/json;charset=utf-8"
    
httpRequest.send JsonConverter.ConvertToJson(jsonRequest)
    
Do While httpRequest.readyState < 4
    DoEvents
Loop

Set parseResponse = JsonConverter.ParseJson(httpRequest.responseText)
    
Debug.Print "Data.Count:" & parseResponse("Response")("Data").Count
Debug.Print "TotalCount:" & parseResponse("Response")("TotalCount")
Debug.Print "PageSize:" & parseResponse("Response")("PageSize")

まず、jsonRequest.Add “Offset”, 0　としてコードを実行しました。
イミディエイトウインドウには以下のように出力されました。

次に、jsonRequest.Add “Offset”, 200　としてコードを実行しました。
すると、イミディエイトウインドウには以下のように出力されました。

parseResponse(“Response”)(“TotalCount”) は299のまま変わらず、
parseResponse(“Response”)(“Data”).Count は99となっています。

また、parseResponse(“Response”)(“PageSize”) は200と出ていますので、取得サイズの上限が200ということが分かります。

３．Offsetしてやってみる。

ためしに、Offsetのところを0にして出力した結果、200にして出力した結果を見てみます。
わかりやすいようにResultIDの昇順でソートして出力します。

Sub pleasanter_export12()
    Const myApikey As String = "12345abcde"
       
    Dim jsonRequest     As Dictionary
    Dim parseResponse   As Dictionary
    Dim httpRequest     As Object



    Set jsonRequest = New Dictionary

    jsonRequest.Add "ApiVersion", "1.1"
    jsonRequest.Add "ApiKey", myApikey
'１回目はOffset0で出力
    jsonRequest.Add "Offset", 0
'２回目はOffset200で出力
    'jsonRequest.Add "Offset", 200
    jsonRequest.Add "View", New Dictionary
    jsonRequest("View").Add "ColumnSorterHash", New Dictionary
    jsonRequest("View")("ColumnSorterHash").Add "ResultId", "asc"
    
    Set httpRequest = CreateObject("msxml2.xmlhttp")
    
    httpRequest.Open "POST", "http://localhost/api/items/426/get"
    httpRequest.setRequestHeader "Content-Type", "application/json;charset=utf-8"
    
    httpRequest.send JsonConverter.ConvertToJson(jsonRequest)
    
    Do While httpRequest.readyState < 4
        DoEvents
    Loop

    Set parseResponse = JsonConverter.ParseJson(httpRequest.responseText)
    
    If parseResponse("Response")("Data").Count <= 0 Then
        MsgBox "なし"
        Exit Sub
    End If
    
    Debug.Print "Data.Count:" & parseResponse("Response")("Data").Count
    Debug.Print "TotalCount:" & parseResponse("Response")("TotalCount")
    Debug.Print "PageSize:" & parseResponse("Response")("PageSize")
    
    Dim responseData As Variant
    Dim i As Long: i = 2
    For Each responseData In parseResponse("Response")("Data")
        With ActiveSheet
            .Cells(i, 1).Value = responseData("Title")
            .Cells(i, 2).Value = responseData("ClassHash")("ClassA")
            .Cells(i, 3).Value = responseData("ClassHash")("ClassB")
            .Cells(i, 4).Value = responseData("ClassHash")("ClassC")
            .Cells(i, 5).Value = responseData("NumHash")("NumA")
            .Cells(i, 6).Value = responseData("NumHash")("NumB")
            .Cells(i, 7).Value = responseData("DateHash")("DateA")
            .Cells(i, 8).Value = responseData("DescriptionHash")("DescriptionA")
            .Cells(i, 9).Value = responseData("CheckHash")("CheckA")
            .Cells(i, 10).Value = responseData("CheckHash")("CheckB")
            .Cells(i, 11).Value = responseData("Owner")
            .Cells(i, 12).Value = responseData("UpdatedTime")
            .Cells(i, 13).Value = responseData("Updator")
            .Cells(i, 14).Value = responseData("Creator")
            .Cells(i, 15).Value = responseData("ResultId")
        End With
        i = i + 1
    Next

    MsgBox "出力完了"
End Sub

１回目

２回目

１回目はちゃんと（？）200レコードでちょん切れています。２回目は201レコードから出力されて、最後の299レコードまで出力されています。

４．TotalCountとpageSizeを利用して全件を出力するコード

コードです。

Sub pleasanter_export12()
    Const myApikey As String = "12345abcde"

    Dim jsonRequest     As Dictionary
    Dim parseResponse   As Dictionary
    Dim httpRequest     As Object
’※1
    Dim offsetCnt As Long: offsetCnt = 0
    Dim endFlg As Boolean: endFlg = False
    Dim i As Long: i = 2
’※2 
    Do Until endFlg = True
’※3   
        Set jsonRequest = New Dictionary
        jsonRequest.Add "ApiVersion", "1.1"
        jsonRequest.Add "ApiKey", myApikey
        jsonRequest.Add "Offset", offsetCnt
        jsonRequest.Add "View", New Dictionary
        jsonRequest("View").Add "ColumnSorterHash", New Dictionary
        jsonRequest("View")("ColumnSorterHash").Add "ResultId", "asc"
        
        Set httpRequest = CreateObject("msxml2.xmlhttp")
        
        httpRequest.Open "POST", "http://localhost/api/items/426/get"
        httpRequest.setRequestHeader "Content-Type", "application/json;charset=utf-8"
        
        httpRequest.send JsonConverter.ConvertToJson(jsonRequest)
        
        Do While httpRequest.readyState < 4
            DoEvents
        Loop
    
        Set parseResponse = JsonConverter.ParseJson(httpRequest.responseText)
’※4         
        If parseResponse("Response")("TotalCount") = 0 Then
            MsgBox "出力データなし"
            Exit Sub
        End If
’※5        
        If offsetCnt + parseResponse("Response")("PageSize") >= parseResponse("Response")("TotalCount") Then
            endFlg = True
        Else
            offsetCnt = offsetCnt + parseResponse("Response")("PageSize")
        End If
        
        Dim responseData As Variant
        For Each responseData In parseResponse("Response")("Data")
            With ActiveSheet
                .Cells(i, 1).Value = responseData("Title")
                .Cells(i, 2).Value = responseData("ClassHash")("ClassA")
                .Cells(i, 3).Value = responseData("ClassHash")("ClassB")
                .Cells(i, 4).Value = responseData("ClassHash")("ClassC")
                .Cells(i, 5).Value = responseData("NumHash")("NumA")
                .Cells(i, 6).Value = responseData("NumHash")("NumB")
                .Cells(i, 7).Value = responseData("DateHash")("DateA")
                .Cells(i, 8).Value = responseData("DescriptionHash")("DescriptionA")
                .Cells(i, 9).Value = responseData("CheckHash")("CheckA")
                .Cells(i, 10).Value = responseData("CheckHash")("CheckB")
                .Cells(i, 11).Value = responseData("Owner")
                .Cells(i, 12).Value = responseData("UpdatedTime")
                .Cells(i, 13).Value = responseData("Updator")
                .Cells(i, 14).Value = responseData("Creator")
                .Cells(i, 15).Value = responseData("ResultId")
            End With
            i = i + 1
        Next
        
        Set jsonRequest = Nothing
        Set httpRequest = Nothing
        Set parseResponse = Nothing
        
    Loop

    MsgBox "出力完了"
End Sub

※印のところを解説します。ほかは割愛します。

’※1
    Dim offsetCnt As Long: offsetCnt = 0
    Dim endFlg As Boolean: endFlg = False
    Dim i As Long: i = 2

変数の準備です。
offsetCntではオフセットの開始位置を指定します。初期値には0を入れておきます。
endFlgは、ループを終了するかどうかのフラグです。ループ終了条件となったらendFlgをTrueにします。
i はエクセルワークシートの出力行です。初期値に2を入れています。出力するごとに1をプラスしていきます。

’※2 
    Do Until endFlg = True
　　    ここに出力処理
    Loop

endFlg が True になるまでプリザンターからのデータ取得＆エクセル出力の処理を繰り返します。
endFlgがTrueの場合はループを終了します。

’※3   
    Set jsonRequest = New Dictionary
    jsonRequest.Add "ApiVersion", "1.1"
    jsonRequest.Add "ApiKey", myApikey
    jsonRequest.Add "Offset", offsetCnt
    jsonRequest.Add "View", New Dictionary
    jsonRequest("View").Add "ColumnSorterHash", New Dictionary
    jsonRequest("View")("ColumnSorterHash").Add "ResultId", "asc"

jsonRequest.Add “Offset”, offsetCnt　のところで、Offsetに初回は0をセットします。
2ループ目では200、3ループ目では400をセットすることになります。

結果が分かりやすいように、ColumnSorterHash でResultId昇順になるように設定しています。

ちなみに、上記のjsonRequestをjson形式にしたイメージは以下のようになっています。
vbaではディクショナリにしていますが、json形式にパースしたイメージはdebug.printすることでイミディエイトウインドウに出力できます。
Debug.Print JsonConverter.ConvertToJson(jsonRequest)

’※4         
    If parseResponse("Response")("TotalCount") = 0 Then
        MsgBox "出力データなし"
        Exit Sub
    End If

TotalCountを検査して、0の場合はそもそもデータがないので、ExitSubで処理を終了します。

’※5        
    If offsetCnt + parseResponse("Response")("PageSize") >= parseResponse("Response")("TotalCount") Then
        endFlg = True
    Else
        offsetCnt = offsetCnt + parseResponse("Response")("PageSize")
    End If

ここが貧弱な脳みその私には難しかった。
上記引用したFAQで
(開始位置 + 一度に取得できる件数) > 全件
とある。

１回目
offsetCnt(0) ＋ PageSize(200) = 200
totalCount = 299
totalCount の方が大きいので endFlg はFalseのまま
　Elseの処理に流れ、offsetCnt に PageSize(200) をプラス

２回目
　offsetCnt(200) ＋ PageSize(200) = 400
totalCount = 299
totalCount の方が小さいので endFlg を true にする
　次のループには進まない。

５．別解のコード

ほかの方法でもできそうだなあと、TotalCountとPageSizeから最初に必要ループ回数を求める方法でもやってみました。でも、４の方がすっきりしていいような気がします。
出力件数が多い場合は以下のコードのようにいったん配列に蓄積しておいて、最後にまとめてワークシートに出力するほうが処理速度が早い（はず）です。

変更点
・最初にTotalCountとPageSizeでループ回数を決める。
・ループを繰り返すような大きな出力になる場合、レコードごとにエクセルに出力していると時間がかかるので、いったん配列に入れてから出力する。

解説に代えてコメント多めに入れています。

Sub pleasanter_export13()
    Const myApikey As String = "12345abcde"
       
    Dim jsonRequest     As Dictionary
    Dim parseResponse   As Dictionary
    Dim httpRequest     As Object
    Dim offsetCnt As Long: offsetCnt = 0        'オフセット
    Dim totalCount As Long                      '全件件数
    Dim pageSize As Long                        'ページサイズ
    Dim loopCnt As Long: loopCnt = 1            'ループ回数カウント用
    Dim maxloopCnt As Long: maxloopCnt = -1     '必要ループ回数。初期値に-1を代入しておく
    Dim arr() As Variant                        '出力データを一時格納しておく配列
    Dim idx As Long: idx = 1                    '配列行方向インデックス
    
    Do
        Set jsonRequest = New Dictionary
        
        jsonRequest.Add "ApiVersion", "1.1"
        jsonRequest.Add "ApiKey", myApikey
        jsonRequest.Add "Offset", offsetCnt
        jsonRequest.Add "View", New Dictionary
        jsonRequest("View").Add "ColumnSorterHash", New Dictionary
        jsonRequest("View")("ColumnSorterHash").Add "ResultId", "asc"
        
        Set httpRequest = CreateObject("msxml2.xmlhttp")
        
        httpRequest.Open "POST", "http://localhost/api/items/426/get"
        httpRequest.setRequestHeader "Content-Type", "application/json;charset=utf-8"
        
        httpRequest.send JsonConverter.ConvertToJson(jsonRequest)
        
        Do While httpRequest.readyState < 4
            DoEvents
        Loop
    
        Set parseResponse = JsonConverter.ParseJson(httpRequest.responseText)
        
        '最初のループでのみ（maxloopCntが-1であることで初回ループであることを判定）以下のIf文に進み
        'ループ回数を決定、および配列のサイズを再宣言して確定
        If maxloopCnt = -1 Then
            totalCount = parseResponse("Response")("TotalCount")    '全件件数
            pageSize = parseResponse("Response")("PageSize")        'ページサイズ
            '件数が0件の場合、処理終了
            If totalCount = 0 Then
                MsgBox "出力データなし"
                Exit Sub
            Else
            '全件件数÷ページサイズの切り上げでループ回数を決定
                maxloopCnt = Application.WorksheetFunction.RoundUp(totalCount / pageSize, 0)
            'データを一時格納する配列の再宣言（縦：全件件数、横：必要なカラム数）
                ReDim arr(1 To totalCount, 1 To 15)
            End If
        End If
        
        Dim responseData As Variant
        For Each responseData In parseResponse("Response")("Data")
            arr(idx, 1) = responseData("Title")
            arr(idx, 2) = responseData("ClassHash")("ClassA")
            arr(idx, 3) = responseData("ClassHash")("ClassB")
            arr(idx, 4) = responseData("ClassHash")("ClassC")
            arr(idx, 5) = responseData("NumHash")("NumA")
            arr(idx, 6) = responseData("NumHash")("NumB")
            arr(idx, 7) = responseData("DateHash")("DateA")
            arr(idx, 8) = responseData("DescriptionHash")("DescriptionA")
            arr(idx, 9) = responseData("CheckHash")("CheckA")
            arr(idx, 10) = responseData("CheckHash")("CheckB")
            arr(idx, 11) = responseData("Owner")
            arr(idx, 12) = responseData("UpdatedTime")
            arr(idx, 13) = responseData("Updator")
            arr(idx, 14) = responseData("Creator")
            arr(idx, 15) = responseData("ResultId")
            idx = idx + 1
        Next
        
        Set jsonRequest = Nothing
        Set httpRequest = Nothing
        Set parseResponse = Nothing
        
        'ループ数をカウントアップ
        loopCnt = loopCnt + 1
        'オフセット（開始位置）をページサイズ(200)分だけ増加させる
        offsetCnt = offsetCnt + pageSize
        
    'ループ回数（loopCnt）が必要ループ回数(maxLoopCnt）より大きくなったらループ終了
    Loop Until maxloopCnt < loopCnt
    
    '配列の内容をエクセルシートに出力
    With ActiveSheet
        .Range("A2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
    End With

    MsgBox "出力完了"
End Sub