2020年3月6日 / 最終更新日時 : 2024年1月12日 officeの杜 JavaScript

VBAからkintoneデータをOAuth2.0認証で読み書きする - 実戦編

前回の記事にて、kintoneのOAuth2.0認証周りを実装しました。これにより、あとはAPIを叩いて、データを取得したり、kintone側のデータを更新する事が可能になります。この仕組を使う事で、kintone側で装備したりプラグイン開発といった事をする必要がなく、使い慣れたExcelやAccess側で制御が可能になります。また、JSは使い手なら大量のライブラリを使いこなせますが、そうではない中小企業の場合VBA側のほうがしっかりしたGUIを構築できるメリットもあります。

今回は取得したAccess Tokenを用いて、APIを実際に叩いてみてkintoneのデータの処理をしてみたいと思います。まずは、データの一括取得、そして実際に承認作業をしてkintone側の対象のレコードを更新する、対象のレコードを削除する、新規レコードの追加という最も重要な部分を実装します。

今回使用するファイル等

kintone側へ更新用データを送る為にJSONを組み立てる必要があるため、VBA-JSONを今回は利用しています。また引き続き、暗号化のためのモジュールも前回に引き続き含まれています。

新方式が登場しました

IE11の廃止に伴い、SeleniumやNode.jsやらといった手段を使わず、またPuppeteerと同様の手法（CDPを叩く）でVBAとEdge/ChromeのみでOAuth2.0認証する手段が登場しました。スクレイピングも可能になっています。以下のエントリーを参考にしてみてください。この手法は最も制限が無く、もっともすぐれた選択肢になると思います。

VBAでOAuth2.0認証 - 新方式を試してみた

事前準備

参照設定

本プログラムは今回、DictionaryやOutlookを使う為に参照設定が必要です。

Microsoft Outlook 16.0 Object Library – Outlookを遠隔操作するために必要
Microsoft Scripting Runtime – Dictionaryを使うために必要

APP IDの取得と保存

今回から予め作成しておいた「アプリ」のAPP IDが別途必要になります。このAPP IDは、アプリのURLにある数字がそれになりますので、これを前回の設定用UIに新たな項目として、レジストリに保存できるように追加してあげましょう。URLは以下のような感じになります。

https://ドメイン名.cybozu.com/k/999/

この999の部分がAPP IDとなり、アプリ毎に異なります。

Private Sub CommandButton1_Click()
'入力内容を取得する
Dim apikey As String
Dim apitoken As String
Dim subdomain As String
Dim redirect As String
Dim userid As String
Dim regpass As String
Dim appid As String
Dim lRet As Variant
subdomain = Me.TextBox3.Value
redirect = Me.TextBox4.Value
userid = Me.TextBox5.Value
regpass = Me.TextBox6.Value
appid = Me.TextBox7.Value
'入力内容でもってレジストリにデータを登録
lRet = RegSetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"subdomain", _
REG_SZ, _
subdomain)
lRet = RegSetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"redirect", _
REG_SZ, _
redirect)
lRet = RegSetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"userid", _
REG_SZ, _
userid)
lRet = RegSetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"appid", _
REG_SZ, _
appid)
lRet = RegSetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"kinpass", _
REG_SZ, _
aes128encode(regpass))
'フォームを閉じる
Unload UserForm1
End Sub
'UserFormがロードされた時に発動
Private Sub UserForm_Initialize()
'レジストリ項目をボックスにロードする
On Error Resume Next
'パスワード入力欄を*に変換する
TextBox6.PasswordChar = "*"
TextBox6.TextAlign = fmTextAlignLeft
'レジストリからID等を読み取る
Dim subdomain As String
Dim appid As String
Dim userid As String
Dim regpass As String
Dim redirect As String
subdomain = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"subdomain", _
REG_SZ, _
0)
appid = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"appid", _
REG_SZ, _
0)
userid = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"userid", _
REG_SZ, _
0)
redirect = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"redirect", _
REG_SZ, _
0)
Me.TextBox3.Value = subdomain
Me.TextBox4.Value = redirect
Me.TextBox5.Value = userid
Me.TextBox7.Value = appid
'レジストリのパスワードを復号化して取り出す
regpass = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"kinpass", _
REG_SZ, _
0)
Me.TextBox6.Value = aes128decode(regpass)
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

Private Sub CommandButton1_Click()

'入力内容を取得する

Dim apikey As String

Dim apitoken As String

Dim subdomain As String

Dim redirect As String

Dim userid As String

Dim regpass As String

Dim appid As String

Dim lRet As Variant

subdomain = Me.TextBox3.Value

redirect = Me.TextBox4.Value

userid = Me.TextBox5.Value

regpass = Me.TextBox6.Value

appid = Me.TextBox7.Value

'入力内容でもってレジストリにデータを登録

lRet = RegSetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"subdomain", _

REG_SZ, _

subdomain)

lRet = RegSetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"redirect", _

REG_SZ, _

redirect)

lRet = RegSetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"userid", _

REG_SZ, _

userid)

lRet = RegSetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"appid", _

REG_SZ, _

appid)

lRet = RegSetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"kinpass", _

REG_SZ, _

aes128encode(regpass))

'フォームを閉じる

Unload UserForm1

End Sub

'UserFormがロードされた時に発動

Private Sub UserForm_Initialize()

'レジストリ項目をボックスにロードする

On Error Resume Next

'パスワード入力欄を*に変換する

TextBox6.PasswordChar = "*"

TextBox6.TextAlign = fmTextAlignLeft

'レジストリからID等を読み取る

Dim subdomain As String

Dim appid As String

Dim userid As String

Dim regpass As String

Dim redirect As String

subdomain = RegGetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"subdomain", _

REG_SZ, _

appid = RegGetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"appid", _

REG_SZ, _

userid = RegGetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"userid", _

REG_SZ, _

redirect = RegGetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"redirect", _

REG_SZ, _

Me.TextBox3.Value = subdomain

Me.TextBox4.Value = redirect

Me.TextBox5.Value = userid

Me.TextBox7.Value = appid

'レジストリのパスワードを復号化して取り出す

regpass = RegGetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"kinpass", _

REG_SZ, _

Me.TextBox6.Value = aes128decode(regpass)

End Sub

図：UserFormにはこのように増設しました

シート側の列の設定

一括取得等の為にシートを用意します。シート名はkintoneとし、kintone側のテーブルと同じような列構成で作っておきます。データの一括取得や、処理フラグなどを格納するようにkintone側で作成しておく必要がありますので、テーブル設計はしっかりおこないましょう。

図：テーブル設計はアプリ作成の肝です

図：シート側も同じ設計にしておく

承認用のフォームを用意する

UserForm2として承認用のフォームを新規に用意します。摘要欄だけはプロパティとして

EnterkeyBeheiviorをTrueにする（Enterキーで改行になります）
MultilineをTrueにする（複数行かけるようになる）
ScrollBarsは「2 - fmScrollBarsVertical」とする（縦だけスクロールバー表示）

として設定しています。他はテキストボックスを用意して、初期化時に選択したレコードデータを格納します。また、承認・却下用のボタンを用意し、それぞれに処理を記述する必要があります。

図：承認用のダイアログがこれで用意できました。

新規追加用フォーム

UserForm3として新規追加用のフォームを用意します。使用用途欄のプロパティは

EnterkeyBeheiviorをTrueにする（Enterキーで改行になります）
MultilineをTrueにする（複数行かけるようになる）
ScrollBarsは「2 - fmScrollBarsVertical」とする（縦だけスクロールバー表示）

として設定。他にも細かくデザイン上の設定変更や、数値の欄は右揃えにする等のプロパティ変更をしています。

また今回は、通常VBAのUserForm上では使えないカレンダーコントロールについて、こちらのクラスを利用する事でOS標準で入ってるCommon Controlの1つである「DTPicker」をVBA上から利用する事ができました。詳しくはクラス公開ページを良く読んでから装備してみてください。Visual Basic 6.0 runtimeの別途インストールは不要です（Windows10の場合）

図：データ追加用のダイアログはちょっとだけ豪華

ソースコード

データの一括取得

もっともよく利用する項目がデータの一括取得。ただし、データには既に処理が完了済みのものもあり、これらのデータまで毎回取得するのは合理的ではなく、またコードも複雑怪奇になります。また、kintoneは現在一括取得では最大500レコードぽっちしか取得できない制限があるため（2020年7月には10000件まで増やすようですが・・・・）、例えば、500件以上の未処理データがある場合には、数回に分けて取得するといった事が必要になります。

今回は以下の事を考慮して設計します。

レコード番号を元に、既に取得済みデータについては取得対象とはしない
承認が未処理のレコードについては取得対象としない

小規模な組織であればこれだけで速度面や制限面もクリアしつつ十分な運用が出来るはずです。kintoneでは「指定したフィールドが空のものを抽出」がAPIでやる方法が無いので、空ではなく、未処理状態のものと定義づけて処理をすると良いです。それが出来ない場合、空で抽出するのではなく一度取得後空かどうか判定して、Excelに貼り付ける事になります。よって、未処理状態は初期値「未処理」が入るようにフィールドに設定しておきましょう。

'APIアクセス用エンドポイントURL
Private Const kingetdata As String = "https://ここにドメイン名.cybozu.com/k/v1/records.json?"
'kintoneの未処理データを一括で取得する
Public Function kintoneGetdata()
'変数を宣言
Dim appid As String
Dim query As String
Dim totalCount As Integer
Dim access_token As String
Dim actflg As Boolean
Dim ret As Boolean
Dim temptoken As String
Dim result As Variant
'問い合わせ
result = MsgBox("kintoneから最新のデータを受信しますか？？", vbYesNo + vbDefaultButton2 + vbExclamation)
If result = vbYes Then
'インポート処理を続行する
Else
'メッセージを表示
MsgBox "処理をキャンセルしました。"
'終了処理
Exit Function
End If
'APP IDを取得する
appid = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"appid", _
REG_SZ, _
0)
'アクセストークンの期限切れチェック
actflg = checkExpireToken()
If actflg = False Then
'新しくトークンを取得し直す
ret = getNewToken()
'トークンが取得し直せたか判定
If ret = False Then
MsgBox "Access Tokenの再取得に失敗しました。再度認証し直してください。"
Exit Function
End If
End If
'アクセストークンを取り出す
temptoken = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"access_token", _
REG_SZ, _
0)
access_token = aes128decode(temptoken)
'シートの取得済みの最大レコード番号を取得する
Dim recnum As Long
With Application.WorksheetFunction
recnum = .Max(ThisWorkbook.Worksheets("kintone").Range("A:A"))
End With
'抽出クエリを組み立てる(500レコード、recnum以降のレコードを指定）
query = "品目名 in (""封筒ラベル"") and 承認 = ""未処理"" and レコード番号 > " & recnum & " order by レコード番号 asc limit 500"
'抽出クエリをURLエンコードする
query = WorksheetFunction.EncodeURL(query)
'リクエストURLを組み立てる
Dim requrl As String
requrl = kingetdata & "app=" & appid & "&totalCount=true&query=" & query
'kintoneへデータをリクエスト
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", requrl, False
.setProxy 2, proxyuri  'プロキシサーバのURLとポート番号
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Authorization", "Bearer " & access_token
.send
'ステータスを取得
Dim status As String
status = .status
'ステータスに従って処理を分岐
Select Case .status
Case 200
'JSON取得用
Dim doc, jsn
Dim tempjson, temprec, tempval
'HTMLDocumentを取得
Set doc = CreateObject("HtmlFile")
'scriptタグを追加
doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
'JSONデータを取得する
Json = .responseText
'パース関数でJSONオブジェクトを取得
Set jsn = doc.JsonParse(Json)
'レコード数を取得する
totalCount = jsn.totalCount
'jsn.recordが空の場合データなしとみなす
If jsn.records = "" Then
MsgBox "現在最新のレコードを取り込み済みです"
Exit Function
End If
'ワークシートの列データを取得する
Dim colArray
Dim colcnt
Dim colname As String
colArray = ThisWorkbook.Worksheets("kintone").Range("A1:O1")
'列データのカラム件数を取得する
colcnt = UBound(colArray, 2)
'件数が1件以上ある場合
If totalCount >= 1 Then
'書き込み用配列を定義する
'totalCountの値がレコード件数、14が列数
Dim dataArray() As Variant
Dim testday As Variant
Dim testvalue As Variant
ReDim dataArray(totalCount, colcnt)
For i = 0 To totalCount - 1
'配列データを取得する
Set tempjson = CallByName(jsn.records, i, VbGet)
'配列にデータを流し込む
For j = 1 To colcnt
'要素名を取得する
colname = colArray(1, j)
'配列にデータを流し込む
Set temprec = CallByName(tempjson, colname, VbGet)
testvalue = CallByName(temprec, "value", VbGet)
'特定の日付列の場合には加工する
If colname = "更新日時" Or colname = "依頼日" Then
'日付の部分だけを取り出す
testday = Left(testvalue, 10)
'ハイフンをスラッシュに変換
testday = Replace(testday, "-", "/")
'配列にぶっこむ
dataArray(i, j - 1) = testday
Else
'配列にぶっこむ
dataArray(i, j - 1) = testvalue
End If
Next j
Next i
'シートの最終列および最終行を取得する
Dim lastrow As Long
Dim startrow As Long
Dim endrow As Long
lastrow = ThisWorkbook.Worksheets("kintone").UsedRange.Rows.Count
startrow = lastrow + 1
endrow = startrow + totalCount
'シートに書き出す
ThisWorkbook.Worksheets("kintone").Range("A" & startrow & ":O" & endrow) = dataArray
Else
'取り込むデータがなかった場合
MsgBox "取り込めるデータはありませんでした。"
Exit Function
End If
Case Else
'データ取得失敗
MsgBox "データの取得に失敗しました"
Exit Function
End Select
End With
'終了処理
MsgBox "取込が完了しました。"
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

'APIアクセス用エンドポイントURL

Private Const kingetdata As String = "https://ここにドメイン名.cybozu.com/k/v1/records.json?"

'kintoneの未処理データを一括で取得する

Public Function kintoneGetdata()

'変数を宣言

Dim appid As String

Dim query As String

Dim totalCount As Integer

Dim access_token As String

Dim actflg As Boolean

Dim ret As Boolean

Dim temptoken As String

Dim result As Variant

'問い合わせ

result = MsgBox("kintoneから最新のデータを受信しますか？？", vbYesNo + vbDefaultButton2 + vbExclamation)

If result = vbYes Then

'インポート処理を続行する

Else

'メッセージを表示

MsgBox "処理をキャンセルしました。"

'終了処理

Exit Function

End If

'APP IDを取得する

appid = RegGetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"appid", _

REG_SZ, _

'アクセストークンの期限切れチェック

actflg = checkExpireToken()

If actflg = False Then

'新しくトークンを取得し直す

ret = getNewToken()

'トークンが取得し直せたか判定

If ret = False Then

MsgBox "Access Tokenの再取得に失敗しました。再度認証し直してください。"

Exit Function

End If

'アクセストークンを取り出す

temptoken = RegGetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"access_token", _

REG_SZ, _

access_token = aes128decode(temptoken)

'シートの取得済みの最大レコード番号を取得する

Dim recnum As Long

With Application.WorksheetFunction

recnum = .Max(ThisWorkbook.Worksheets("kintone").Range("A:A"))

End With

'抽出クエリを組み立てる(500レコード、recnum以降のレコードを指定）

query = "品目名 in (""封筒ラベル"") and 承認 = ""未処理"" and レコード番号 > " & recnum & " order by レコード番号 asc limit 500"

'抽出クエリをURLエンコードする

query = WorksheetFunction.EncodeURL(query)

'リクエストURLを組み立てる

Dim requrl As String

requrl = kingetdata & "app=" & appid & "&totalCount=true&query=" & query

'kintoneへデータをリクエスト

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open "GET", requrl, False

.setProxy 2, proxyuri 'プロキシサーバのURLとポート番号

.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

.setRequestHeader "Authorization", "Bearer " & access_token

.send

'ステータスを取得

Dim status As String

status = .status

'ステータスに従って処理を分岐

Select Case .status

Case 200

'JSON取得用

Dim doc, jsn

Dim tempjson, temprec, tempval

'HTMLDocumentを取得

Set doc = CreateObject("HtmlFile")

'scriptタグを追加

doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"

'JSONデータを取得する

Json = .responseText

'パース関数でJSONオブジェクトを取得

Set jsn = doc.JsonParse(Json)

'レコード数を取得する

totalCount = jsn.totalCount

'jsn.recordが空の場合データなしとみなす

If jsn.records = "" Then

MsgBox "現在最新のレコードを取り込み済みです"

Exit Function

End If

'ワークシートの列データを取得する

Dim colArray

Dim colcnt

Dim colname As String

colArray = ThisWorkbook.Worksheets("kintone").Range("A1:O1")

'列データのカラム件数を取得する

colcnt = UBound(colArray, 2)

'件数が1件以上ある場合

If totalCount >= 1 Then

'書き込み用配列を定義する

'totalCountの値がレコード件数、14が列数

Dim dataArray() As Variant

Dim testday As Variant

Dim testvalue As Variant

ReDim dataArray(totalCount, colcnt)

For i = 0 To totalCount - 1

'配列データを取得する

Set tempjson = CallByName(jsn.records, i, VbGet)

'配列にデータを流し込む

For j = 1 To colcnt

'要素名を取得する

colname = colArray(1, j)

'配列にデータを流し込む

Set temprec = CallByName(tempjson, colname, VbGet)

testvalue = CallByName(temprec, "value", VbGet)

'特定の日付列の場合には加工する

If colname = "更新日時" Or colname = "依頼日" Then

'日付の部分だけを取り出す

testday = Left(testvalue, 10)

'ハイフンをスラッシュに変換

testday = Replace(testday, "-", "/")

'配列にぶっこむ

dataArray(i, j - 1) = testday

Else

'配列にぶっこむ

dataArray(i, j - 1) = testvalue

End If

Next j

Next i

'シートの最終列および最終行を取得する

Dim lastrow As Long

Dim startrow As Long

Dim endrow As Long

lastrow = ThisWorkbook.Worksheets("kintone").UsedRange.Rows.Count

startrow = lastrow + 1

endrow = startrow + totalCount

'シートに書き出す

ThisWorkbook.Worksheets("kintone").Range("A" & startrow & ":O" & endrow) = dataArray

Else

'取り込むデータがなかった場合

MsgBox "取り込めるデータはありませんでした。"

Exit Function

End If

Case Else

'データ取得失敗

MsgBox "データの取得に失敗しました"

Exit Function

End Select

End With

'終了処理

MsgBox "取込が完了しました。"

End Function

データ取得用のエンドポイントURLは、kingetdataに記してある通りのものになります。cursorと呼ばれるAPIもあります。
Access Tokenの期限切れチェック＆再取得ルーチンをまず走らせます。
今回より新たに追加したAPP IDをレジストリから取得します。
offsetは指定した分のレコード数だけ飛ばして表示するので、クエリの結果5件返ってきた場合、offsetが2の場合、3件目～のデータを受信する。レコード番号とは関係ないので注意。
query文字列が嵌るポイントです。ドロップダウン項目は項目名 in (""項目の値"")としてクエリを作る必要があります。複数つなげる場合にはand演算子でつないで条件指定をします。
空文字での検索はできないので、どこか判定になる列で今回は未処理だったらという条件で取得します。
レコード番号順でorder byを指定し、レコード番号最大値以上、取得件数は最大値の500をlimitとして指定しています。
query文字列は必ず「URLエンコード」してから渡す必要があります。
アクセスするURLにAPP IDとtotalCount=trueのオプション、query文字列をつなげて、GETで通信します。
VBA-JSONは正直扱いが面倒（特にJSONオブジェクトのキー名に変数が素直に使えない）ので、いつものParseをしています。
jsn.recordsが空の場合、取得できるデータがないのでそこで終了です。
kintoneシートのカラム列名でCallByName関数にてkeyの指定として利用しています。
配列を用意し、同じレコード数・カラム数で拡張、データをCallByName関数でvalueを取得し流し込んであげます。
最後にシートの最終行以下に新しく取得した配列データを書き込みしています。
totalCountですが、これはqueryでフィルタされたあとの件数ではなくフィルタされる前の件数なので注意。これが500を超えている場合にはtotalCount/500の回数だけGETで叩けば全てのデータを取得可能です。

全データを取得する

レコード取得のAPIについては、cursorを使った手法では10,000件まで取得可能ですが、通常のAPIでは500件がMAXです。そのため、kintoneのテーブルに500件以上ある場合、何度か回さないと取得ができません。それほど多く利用するシーンは無いと思いますが、無いと困るので、作りました。

以下のコードはExcelではなくAccess用に作っていますが、適当に関数などを書き直せば動くと思います。必要な部分だけを掲載しています。

'データ取得用変数
Dim lastset As Boolean
Dim loopcnt As Variant
'取得件数リミット（最大値は500）
Dim reclimit As Integer
reclimit = 500
'lastsetがfalseの間はループを回す
Do Until lastset = True
'テーブルの取得済みの最大レコード番号を取得する
recnum = DMax("レコード番号", "終了済み一覧")
'recnumがnullの場合は0として設定
If IsNull(recnum) Then
recnum = 0
End If
'抽出クエリを組み立てる(500レコード、終了済みが-1のものだけ）
'終了済み案件データを取得して更新クエリで反映
query = "endflg = -1 order by レコード番号 asc limit " & reclimit
query = encodeurl(query)
requrl = kingetdata & "app=" & appid & "&totalCount=true&query=" & query
'kintoneへデータをリクエスト
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", requrl, False
.setProxy 2, proxyuri  'プロキシサーバのURLとポート番号
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Authorization", "Bearer " & access_token
.send
'ステータスを取得
status = .status
'ステータスに従って処理を分岐
Select Case .status
Case 200
'HTMLDocumentを取得
Set doc = CreateObject("HtmlFile")
'scriptタグを追加
doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
'JSONデータを取得する
Json = .responseText
'パース関数でJSONオブジェクトを取得
Set jsn = doc.JsonParse(Json)
'レコード数を取得する
totalCount = jsn.totalCount
'リミットから回すべき回数を算出する
If totalCount <= reclimit Then
'はじめからreclimit以下の件数ならばoffsetは1で終了
loopcnt = totalCount
lastset = True
Else
'reclimitがそのままloopcntとなる
loopcnt = reclimit
End If
'jsn.recordが空の場合データなしとみなす
If jsn.records = "" Then
totalCount = 0
Exit Do
Else
'件数が1件以上ある場合
If totalCount >= 1 Then
'DB接続用変数
Set rs = db.OpenRecordset("終了済み一覧", dbOpenDynaset)
For i = 0 To loopcnt - 1
'配列データを取得する
Set tempjson = CallByName(jsn.records, i, VbGet)
'レコードを追加する
With rs
.AddNew
'レコード番号を取得する
Set temprec = CallByName(tempjson, "レコード番号", VbGet)
!レコード番号 = CallByName(temprec, "value", VbGet)
'終了フラグ
Set temprec = CallByName(tempjson, "endflg", VbGet)
!終了済み = CallByName(temprec, "value", VbGet)
.Update
End With
Next i
End If
End If
Case Else
'データ取得失敗
MsgBox "終了済みデータの取得に失敗しました"
Exit Function
End Select
End With
Loop

'データ取得用変数

Dim lastset As Boolean

Dim loopcnt As Variant

'取得件数リミット（最大値は500）

Dim reclimit As Integer

reclimit = 500

'lastsetがfalseの間はループを回す

Do Until lastset = True

'テーブルの取得済みの最大レコード番号を取得する

recnum = DMax("レコード番号", "終了済み一覧")

'recnumがnullの場合は0として設定

If IsNull(recnum) Then

recnum = 0

End If

'抽出クエリを組み立てる(500レコード、終了済みが-1のものだけ）

'終了済み案件データを取得して更新クエリで反映

query = "endflg = -1 order by レコード番号 asc limit " & reclimit

query = encodeurl(query)

requrl = kingetdata & "app=" & appid & "&totalCount=true&query=" & query

'kintoneへデータをリクエスト

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open "GET", requrl, False

.setProxy 2, proxyuri 'プロキシサーバのURLとポート番号

.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

.setRequestHeader "Authorization", "Bearer " & access_token

.send

'ステータスを取得

status = .status

'ステータスに従って処理を分岐

Select Case .status

Case 200

'HTMLDocumentを取得

Set doc = CreateObject("HtmlFile")

'scriptタグを追加

doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"

'JSONデータを取得する

Json = .responseText

'パース関数でJSONオブジェクトを取得

Set jsn = doc.JsonParse(Json)

'レコード数を取得する

totalCount = jsn.totalCount

'リミットから回すべき回数を算出する

If totalCount <= reclimit Then

'はじめからreclimit以下の件数ならばoffsetは1で終了

loopcnt = totalCount

lastset = True

Else

'reclimitがそのままloopcntとなる

loopcnt = reclimit

End If

'jsn.recordが空の場合データなしとみなす

If jsn.records = "" Then

totalCount = 0

Exit Do

Else

'件数が1件以上ある場合

If totalCount >= 1 Then

'DB接続用変数

Set rs = db.OpenRecordset("終了済み一覧", dbOpenDynaset)

For i = 0 To loopcnt - 1

'配列データを取得する

Set tempjson = CallByName(jsn.records, i, VbGet)

'レコードを追加する

With rs

.AddNew

'レコード番号を取得する

Set temprec = CallByName(tempjson, "レコード番号", VbGet)

!レコード番号 = CallByName(temprec, "value", VbGet)

'終了フラグ

Set temprec = CallByName(tempjson, "endflg", VbGet)

!終了済み = CallByName(temprec, "value", VbGet)

.Update

End With

Next i

End If

Case Else

'データ取得失敗

MsgBox "終了済みデータの取得に失敗しました"

Exit Function

End Select

End With

Loop

lastsetがtrueの場合ループから脱出するようにしています。
reclimitは取得できる最大値を指定しています（今回は500）
テーブルより取得済みレコード番号の最大値を取得しておきます。クエリではこれよりも上のレコード番号を取得させます。
POST送信で送り、totalCountが返ってきます。この値は最大値以上の条件での返り値なのでループ毎に減っていきます。
totalCountがreclimit以下かどうかで判定させて、lastsetのフラグをtrueにします。
また、reclimit以下の場合には残りの件数をloopcntに入れ、そうでない場合はreclimitをloopcntに入れます。
loopcntを元にループを回し取得したデータをテーブルに流し込んでいきます。

１ループ毎にレコード番号最大値を取得してクエリを流して、totalCountがreclimit以下になるまで回し続ける事でオフセットなどの計算をせずに全部のレコードを取得可能です。

データの更新

承認フォーム側コード

UserForm2として承認用のフォーム側には、initializeと承認・却下のボタンを用意しています。

'承認ボタンの処理
Private Sub CommandButton1_Click()
'摘要欄のvalidation
If Me.TextBox7.Value = "" Then
MsgBox "摘要欄が空ですよ。"
Exit Sub
Else
tekiyou = Me.TextBox7.Value
End If
'承認フラグを立てる
appflg = "承認"
'ダイアログを非表示にする
Me.Hide
End Sub
'却下ボタンの処理
Private Sub CommandButton2_Click()
'摘要欄のvalidation
If Me.TextBox7.Value = "" Then
MsgBox "摘要欄が空ですよ。"
Exit Sub
Else
tekiyou = Me.TextBox7.Value
End If
'承認フラグを立てる
appflg = "却下"
'ダイアログを非表示にする
Me.Hide
End Sub
'UserForm2を初期化
Private Sub UserForm_Initialize()
'選択レコードの値を各テキストボックスに展開
Me.TextBox1.Value = retArray(1, 1)
Me.TextBox5.Value = retArray(1, 10)
Me.TextBox2.Value = retArray(1, 4)
Me.TextBox3.Value = retArray(1, 5)
Me.TextBox4.Value = retArray(1, 6)
Me.TextBox6.Value = retArray(1, 13)
'摘要欄にフォーカス
Me.TextBox7.SetFocus
End Sub

'承認ボタンの処理

Private Sub CommandButton1_Click()

'摘要欄のvalidation

If Me.TextBox7.Value = "" Then

MsgBox "摘要欄が空ですよ。"

Exit Sub

Else

tekiyou = Me.TextBox7.Value

End If

'承認フラグを立てる

appflg = "承認"

'ダイアログを非表示にする

Me.Hide

End Sub

'却下ボタンの処理

Private Sub CommandButton2_Click()

'摘要欄のvalidation

If Me.TextBox7.Value = "" Then

MsgBox "摘要欄が空ですよ。"

Exit Sub

Else

tekiyou = Me.TextBox7.Value

End If

'承認フラグを立てる

appflg = "却下"

'ダイアログを非表示にする

Me.Hide

End Sub

'UserForm2を初期化

Private Sub UserForm_Initialize()

'選択レコードの値を各テキストボックスに展開

Me.TextBox1.Value = retArray(1, 1)

Me.TextBox5.Value = retArray(1, 10)

Me.TextBox2.Value = retArray(1, 4)

Me.TextBox3.Value = retArray(1, 5)

Me.TextBox4.Value = retArray(1, 6)

Me.TextBox6.Value = retArray(1, 13)

'摘要欄にフォーカス

Me.TextBox7.SetFocus

End Sub

初期化では選択してる行のデータを各テキストボックスに反映しています。
承認及び却下のボタンでは、グローバル変数であるappflgに対してそれぞれの値を格納し、グローバル変数であるtekiyouに摘要欄の値を格納しています。
この時、摘要欄は「Multilineはtrue」となっていて、「EnterkeyBehaviorはTrue」でEnterで改行されます。改行コードとなっているのでメールで送る場合は注意が必要です。
摘要欄が長くなった時の為に、Scrollbarsは「2 - fmScrollBarsVertical」として縦だけ表示するようにしています。

メインの更新用コード

承認および却下をした場合には、kintone側の対象の列の値を変更するだけでなく、入力値を持ってしてExcelの行の値も変更、その後Outlookにてメールを送る処理を作ります。

'APIアクセス用エンドポイントURL
Private Const kingetdata As String = "https://ドメイン名.cybozu.com/k/v1/records.json" '一括取得用
Private Const kinputdata As String = "https://ドメイン名.cybozu.com/k/v1/record.json"  '単一レコード用
'ユーザフォーム用のグローバル配列
Public retArray As Variant
'摘要欄のワード
Public tekiyou As Variant
'選択レコードのIDを格納する
Public selerec As Variant
Public tarrec As Variant
'承認フラグ
Public appflg As String
'選択レコードの承認作業
Public Function kintoneApprove()
'変数初期化
appflg = ""
'現在アクティブになってるシート名を取得する
Dim activesheetman As String
activesheetman = ActiveSheet.Name
'// シートの入力範囲の全セルを取得
Dim rUsed As Range
Set rUsed = ActiveSheet.UsedRange
'行選択されているかどうかチェック
Dim lineman As Boolean
lineman = line_check()
If lineman = False Then
'行選択されていないので終了
MsgBox "行選択されていませんよ"
Exit Function
End If
'選択されている行数が2以上の場合終了
If Selection.Rows.Count >= 2 Then
MsgBox "一度に選択できる行数は1行だけです。"
Exit Function
End If
'選択されている行番号を取得する
Dim rng As Range
For Each rng In Selection.Rows
selerec = rng.Row
Next rng
'レコードデータIDを取得する
tarrec = rUsed(selerec, 1)
'承認列が未処理ではない場合終了
Dim approve As String
approve = rUsed(selerec, 15)
'承認済みの場合の処理
Select Case approve
'承認の場合
Case "承認":
MsgBox "既にこのレコードは承認済みです"
Exit Function
Case "却下":
MsgBox "既にこのレコードは却下となっています。"
Exit Function
End Select
'UserForm2側に送るデータを生成
retArray = ThisWorkbook.Worksheets("kintone").Range("A" & selerec & ":O" & selerec)
'UserForm2を開く
Load UserForm2
UserForm2.Show vbModal
Unload UserForm2
'appflgが空の場合、何もしないで終了（何もしないで閉じた場合の対処）
If appflg = "" Then
Exit Function
End If
'完了日を作成
Dim endday As String
endday = Format(Date, "yyyy-mm-dd")
'承認作業を実行
Dim ret As Boolean
ret = kintonePutData(appflg, endday)
'retの値によって、処理を分岐
If ret = True Then
'承認完了なのでスプレッドシート側も値を書き換える
With ThisWorkbook.Worksheets("kintone")
.Range("H" & selerec) = endday
.Range("N" & selerec) = tekiyou
.Range("O" & selerec) = appflg
End With
'Outlookで本人にメール通知
'Outlookオブジェクトの生成
Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
'MailItemオブジェクトを生成
Set objOutlook = New Outlook.Application
'メール作成インスタンスの作成
Set objMail = objOutlook.CreateItem(olMailItem)
'メール本文等の設定
Dim Subject As String
Dim mailhead As String
Dim mailmsg As String
'メールサブジェクトを取得
Subject = rUsed(selerec, 4) & rUsed(selerec, 5) & "のオーダーについて"
'メールヘッダを作成する
mailhead = rUsed(selerec, 10) & "様<br><br><br>"
'メール・メッセージを組み立て
mailmsg = "<p>頂きました『" & rUsed(selerec, 4) & rUsed(selerec, 5) & "』のオーダーについて" & _
"<font color='red'><b>" & appflg & "</b></font>となりました。詳細については以下の通りです。</p>" & _
"<hr><b>承認者からのコメント：</b><br>" & tekiyou & "<br>"
mailmsg = mailmsg & "<p>承認された場合は、後ほどお届けします。却下された場合は、承認者のコメントを参考に修正し、再オーダーをお願い致します。</p><br><br>"
'改行コードを<br>に置き換え
mailmsg = Replace(mailmsg, vbLf, "<br>")
'メールを組み立てる（HTMLメール形式）
With objMail
.To = rUsed(selerec, 11)
.Subject = Subject
.BodyFormat = olFormatHTML  'メールの形式
.HTMLBody = mailhead & mailmsg  'メール本文
'メールを送信する
.Send
End With
'終了処理
Set objOutlook = Nothing
Set objMail = Nothing
MsgBox "更新が完了しました。"
Else
'承認失敗してるので何もしない
End If
End Function
'行選択されているかどうかチェック
Public Function line_check() As Boolean
'変数の宣言
Dim lineadd As String
lineadd = Selection.Address(False, False)
lineadd = Replace(lineadd, ":", "")
'選択行かどうかを確認
If IsNumeric(lineadd) Then
line_check = True
Else
line_check = False
End If
End Function
'kintone側のレコードを更新するルーティン（単一レコード）
Public Function kintonePutData(approveman As String, approveday As String) As Boolean
'変数の宣言
Dim appid As String
Dim access_token As String
Dim temptoken As String
Dim ret As Variant
'APP IDを取得する
appid = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"appid", _
REG_SZ, _
0)
'アクセストークンの期限切れチェック
actflg = checkExpireToken()
If actflg = False Then
'新しくトークンを取得し直す
ret = getNewToken()
'トークンが取得し直せたか判定
If ret = False Then
MsgBox "Access Tokenの再取得に失敗しました。再度認証し直してください。"
Exit Function
End If
End If
'アクセストークンを取り出す
temptoken = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"access_token", _
REG_SZ, _
0)
access_token = aes128decode(temptoken)
'リクエストデータを組み立て
'http://kimama-vba.com/2019/12/28/kintone-excel-put/
Dim Json_St As String
Dim Json As New Scripting.Dictionary  '外側のJSON用
Dim Rec_Json As New Scripting.Dictionary 'record用
'個別フィールド用
Dim json_approve As New Scripting.Dictionary '承認列
Dim json_tekiyou As New Scripting.Dictionary '摘要列
Dim json_endday As New Scripting.Dictionary  '完了日列
'共通値を追加
Json.Add "app", CInt(appid) 'appIDを指定
Json.Add "id", tarrec '更新対象のレコードID
'各列のデータを生成して1レコード作る
json_approve.Add "value", approveman
json_tekiyou.Add "value", tekiyou
json_endday.Add "value", approveday
With Rec_Json
.Add "承認", json_approve
.Add "摘要", json_tekiyou
.Add "完了日", json_endday
End With
'recordに塊を追加する
Json.Add "record", Rec_Json
'JSONに変換
Json_St = JsonConverter.ConvertToJson(Json)
'HTTPリクエスト
Dim http As New WinHttpRequest
Dim flagman As Boolean
With http
.Open "PUT", kinputdata, False
.setProxy 2, proxyuri  'プロキシサーバのURLとポート番号
.setRequestHeader "Content-Type", "application/json"
.setRequestHeader "Authorization", "Bearer " & access_token
.Send Json_St
'ステータスを取得
Dim status As String
status = .status
Select Case .status
Case 200, 201
flagman = True
Case Else
MsgBox .status & "エラー。承認は失敗しました。"
flagman = False
End Select
End With
'値を返す
kintonePutData = flagman
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

'APIアクセス用エンドポイントURL

Private Const kingetdata As String = "https://ドメイン名.cybozu.com/k/v1/records.json" '一括取得用

Private Const kinputdata As String = "https://ドメイン名.cybozu.com/k/v1/record.json" '単一レコード用

'ユーザフォーム用のグローバル配列

Public retArray As Variant

'摘要欄のワード

Public tekiyou As Variant

'選択レコードのIDを格納する

Public selerec As Variant

Public tarrec As Variant

'承認フラグ

Public appflg As String

'選択レコードの承認作業

Public Function kintoneApprove()

'変数初期化

appflg = ""

'現在アクティブになってるシート名を取得する

Dim activesheetman As String

activesheetman = ActiveSheet.Name

'// シートの入力範囲の全セルを取得

Dim rUsed As Range

Set rUsed = ActiveSheet.UsedRange

'行選択されているかどうかチェック

Dim lineman As Boolean

lineman = line_check()

If lineman = False Then

'行選択されていないので終了

MsgBox "行選択されていませんよ"

Exit Function

End If

'選択されている行数が2以上の場合終了

If Selection.Rows.Count >= 2 Then

MsgBox "一度に選択できる行数は1行だけです。"

Exit Function

End If

'選択されている行番号を取得する

Dim rng As Range

For Each rng In Selection.Rows

selerec = rng.Row

Next rng

'レコードデータIDを取得する

tarrec = rUsed(selerec, 1)

'承認列が未処理ではない場合終了

Dim approve As String

approve = rUsed(selerec, 15)

'承認済みの場合の処理

Select Case approve

'承認の場合

Case "承認":

MsgBox "既にこのレコードは承認済みです"

Exit Function

Case "却下":

MsgBox "既にこのレコードは却下となっています。"

Exit Function

End Select

'UserForm2側に送るデータを生成

retArray = ThisWorkbook.Worksheets("kintone").Range("A" & selerec & ":O" & selerec)

'UserForm2を開く

Load UserForm2

UserForm2.Show vbModal

Unload UserForm2

'appflgが空の場合、何もしないで終了（何もしないで閉じた場合の対処）

If appflg = "" Then

Exit Function

End If

'完了日を作成

Dim endday As String

endday = Format(Date, "yyyy-mm-dd")

'承認作業を実行

Dim ret As Boolean

ret = kintonePutData(appflg, endday)

'retの値によって、処理を分岐

If ret = True Then

'承認完了なのでスプレッドシート側も値を書き換える

With ThisWorkbook.Worksheets("kintone")

.Range("H" & selerec) = endday

.Range("N" & selerec) = tekiyou

.Range("O" & selerec) = appflg

End With

'Outlookで本人にメール通知

'Outlookオブジェクトの生成

Dim objOutlook As Outlook.Application

Dim objMail As Outlook.MailItem

'MailItemオブジェクトを生成

Set objOutlook = New Outlook.Application

'メール作成インスタンスの作成

Set objMail = objOutlook.CreateItem(olMailItem)

'メール本文等の設定

Dim Subject As String

Dim mailhead As String

Dim mailmsg As String

'メールサブジェクトを取得

Subject = rUsed(selerec, 4) & rUsed(selerec, 5) & "のオーダーについて"

'メールヘッダを作成する

mailhead = rUsed(selerec, 10) & "様<br><br><br>"

'メール・メッセージを組み立て

mailmsg = "<p>頂きました『" & rUsed(selerec, 4) & rUsed(selerec, 5) & "』のオーダーについて" & _

"<font color='red'><b>" & appflg & "</b></font>となりました。詳細については以下の通りです。</p>" & _

"<hr><b>承認者からのコメント：</b><br>" & tekiyou & "<br>"

mailmsg = mailmsg & "<p>承認された場合は、後ほどお届けします。却下された場合は、承認者のコメントを参考に修正し、再オーダーをお願い致します。</p><br><br>"

'改行コードを<br>に置き換え

mailmsg = Replace(mailmsg, vbLf, "<br>")

'メールを組み立てる（HTMLメール形式）

With objMail

.To = rUsed(selerec, 11)

.Subject = Subject

.BodyFormat = olFormatHTML 'メールの形式

.HTMLBody = mailhead & mailmsg 'メール本文

'メールを送信する

.Send

End With

'終了処理

Set objOutlook = Nothing

Set objMail = Nothing

MsgBox "更新が完了しました。"

Else

'承認失敗してるので何もしない

End If

End Function

'行選択されているかどうかチェック

Public Function line_check() As Boolean

'変数の宣言

Dim lineadd As String

lineadd = Selection.Address(False, False)

lineadd = Replace(lineadd, ":", "")

'選択行かどうかを確認

If IsNumeric(lineadd) Then

line_check = True

Else

line_check = False

End If

End Function

'kintone側のレコードを更新するルーティン（単一レコード）

Public Function kintonePutData(approveman As String, approveday As String) As Boolean

'変数の宣言

Dim appid As String

Dim access_token As String

Dim temptoken As String

Dim ret As Variant

'APP IDを取得する

appid = RegGetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"appid", _

REG_SZ, _

'アクセストークンの期限切れチェック

actflg = checkExpireToken()

If actflg = False Then

'新しくトークンを取得し直す

ret = getNewToken()

'トークンが取得し直せたか判定

If ret = False Then

MsgBox "Access Tokenの再取得に失敗しました。再度認証し直してください。"

Exit Function

End If

'アクセストークンを取り出す

temptoken = RegGetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"access_token", _

REG_SZ, _

access_token = aes128decode(temptoken)

'リクエストデータを組み立て

'http://kimama-vba.com/2019/12/28/kintone-excel-put/

Dim Json_St As String

Dim Json As New Scripting.Dictionary '外側のJSON用

Dim Rec_Json As New Scripting.Dictionary 'record用

'個別フィールド用

Dim json_approve As New Scripting.Dictionary '承認列

Dim json_tekiyou As New Scripting.Dictionary '摘要列

Dim json_endday As New Scripting.Dictionary '完了日列

'共通値を追加

Json.Add "app", CInt(appid) 'appIDを指定

Json.Add "id", tarrec '更新対象のレコードID

'各列のデータを生成して1レコード作る

json_approve.Add "value", approveman

json_tekiyou.Add "value", tekiyou

json_endday.Add "value", approveday

With Rec_Json

.Add "承認", json_approve

.Add "摘要", json_tekiyou

.Add "完了日", json_endday

End With

'recordに塊を追加する

Json.Add "record", Rec_Json

'JSONに変換

Json_St = JsonConverter.ConvertToJson(Json)

'HTTPリクエスト

Dim http As New WinHttpRequest

Dim flagman As Boolean

With http

.Open "PUT", kinputdata, False

.setProxy 2, proxyuri 'プロキシサーバのURLとポート番号

.setRequestHeader "Content-Type", "application/json"

.setRequestHeader "Authorization", "Bearer " & access_token

.Send Json_St

'ステータスを取得

Dim status As String

status = .status

Select Case .status

Case 200, 201

flagman = True

Case Else

MsgBox .status & "エラー。承認は失敗しました。"

flagman = False

End Select

End With

'値を返す

kintonePutData = flagman

End Function

グローバル変数kinputdataが1行レコードを更新する為のエンドポイントURLになります。recordであってrecordsじゃない点に注意。
UserForm2側の摘要欄(tekiyou)や承認フラグ(appflg）、レコードデータのID(tarrec)、現在選択されている行の番号(selerec)などをグローバル変数で格納します。
line_check関数で行が選択されているかどうかを判定します。
今回は複数行まとめてではなく、1行単位で承認をする仕組みなので、1行以上選択して承認は出来ません。
完了日の日付はyyyy-mm-dd形式でなければなりません。
承認後は承認内容である承認列、完了日、摘要の内容をシートの該当の行に反映します。
また、承認後その内容を元に、Outlookにてメールを送るコードが入っています。その際に摘要欄は改行コードを<br>に変更しています（HTMLメールで送っているため）
kintonePutData関数が、kintone側のレコードを更新する関数になります。
更新するデータはJSONで組み立てて、JsonConverter.ConvertToJsonにてJSON化したものをPUTメソッドにて送信します。
JSONはrecordキーだけが複数のkeyの値を持っている状態にする必要があります。
承認でステータスが200が返ってくれば、trueとして、そうでなければfalseとしてflagmanで返す。この返り値を元にメインルーチンでシート書き込みやメール送信を行います。
シートでは承認された場合は灰色、却下された場合は赤色でレコードが色分けされるように、条件付き書式設定を行っています。

{
"app":418,
"id":6,
"record":{
"承認":{
"value":"承認フラグがここに入る"
},
"摘要":{
"value":"摘要欄の文字列がここに入る"
},
"完了日":{
"value":"2020-03-16"
}
}
}

{

"app":418,

"id":6,

"record":{

"承認":{

"value":"承認フラグがここに入る"

"摘要":{

"value":"摘要欄の文字列がここに入る"

"完了日":{

"value":"2020-03-16"

}

図：承認用のJSONは上記のようなスタイルで構築する

図：承認されると灰色にレコードが変色する

データの新規追加

本来今回のケースの場合、kintone側へデータをExcel側から入れる予定はなかったのですが、これだけやらないというのも気持ち悪いのと、他で流用できるので、ついでに装備することにしました。新規入力用フォームを用意し、尚且新規追加用のコードを用意する必要があります。追加用コードは、更新用コードと殆ど同じ形式なので

新規追加フォーム側コード

フォーム側では主にプルダウンメニューの動的生成およびDTPickerを呼び出すクラスの初期化などを行っています。また、新規追加ボタンのアクションにつても記述しております。

Option Explicit
Private DTPCBox2 As clsDTPickerOnCombo3
'新規追加ボタンクリック時
Private Sub CommandButton1_Click()
'入力値のvalidationを行う
Dim validata As Variant
Dim ret As Variant
'依頼日を生成する
Dim iraibi As String
iraibi = Format(Date, "yyyy-mm-dd")
dataArray(0) = iraibi
'品目名について
validata = hinmoku.Value
If validata = "" Or validata = "品目名を選択してください" Then
MsgBox "品目名が選択されていませんよ"
hinmoku.SetFocus
Exit Sub
Else
dataArray(1) = validata
End If
'品名について
validata = hinmei.Value
If validata = "" Or validata = "品名を選択してください" Then
MsgBox "品名が選択されていませんよ"
hinmei.SetFocus
Exit Sub
Else
dataArray(2) = validata
End If
'数量について
validata = StrConv(suryou.Value, vbNarrow)
If validata = "" Or validata = 0 Then
MsgBox "数量が入っていません"
suryou.SetFocus
Exit Sub
Else
'入力値が数値かどうか判定
If IsNumeric(validata) Then
dataArray(3) = validata
Else
MsgBox "数値じゃない値が入っていますよ"
suryou.SetFocus
Exit Sub
End If
End If
'希望日について
validata = DTPCBox2.Value
dataArray(4) = Replace(validata, "/", "-")
'コードについて
validata = StrConv(pjcode.Value, vbNarrow)
If validata = "" Then
MsgBox "コードが入っていませんよ"
pjcode.SetFocus
Exit Sub
Else
dataArray(5) = validata
End If
'担当者について
validata = tantou.Value
If validata = "" Then
MsgBox "担当者名が入っていませんよ"
tantou.SetFocus
Exit Sub
Else
dataArray(6) = validata
End If
'メールアドレスについて
validata = StrConv(mail.Value, vbNarrow)
If validata = "" Then
MsgBox "メールアドレスが入っていませんよ"
mail.SetFocus
Exit Sub
Else
'有効なメールアドレス形式のチェック
If chkMailAddress(validata) Then
dataArray(7) = validata
Else
MsgBox "有効なメールアドレスの形式ではありません"
mail.SetFocus
Exit Sub
End If
End If
'毎月の場合について
validata = monthman.Value
dataArray(8) = validata
'使用用途について
validata = youto.Value
If validata = "" Then
MsgBox "使用用途が入っていませんよ"
youto.SetFocus
Exit Sub
Else
dataArray(9) = validata
End If
'kintone側へデータをインサート
ret = kintoneInsert()
'retの値によって、処理を分岐
If ret = True Then
'データを再取得する
Call kintoneGetdata
'UserForm3をアンロード
Unload UserForm3
Else
'追加失敗してるので何もしない
End If
End Sub
'品目名プルダウン選択時
Private Sub hinmoku_Change()
'ListIndexの値に応じて変更
Dim listnum As Integer
listnum = hinmoku.ListIndex
'品名プルダウンをクリアする
hinmei.Clear
'選択項目に応じて品名プルダウンを変更
Select Case listnum
Case 0
'何もしない
Case 1
'レターパックの品目にチェンジ
With hinmei
.AddItem "品名を選択してください"
.AddItem "レターパックプラス"
.AddItem "レターパックライト"
End With
'品名プルダウンの初期値
hinmei.ListIndex = 0
Case 2
'封筒の品目にチェンジ
With hinmei
.AddItem "品名を選択してください"
.AddItem "角2"
.AddItem "角2(のりつき)"
.AddItem "角2(のりつき)"
.AddItem "コピー用紙"
.AddItem "コピー用紙(1箱)"
.AddItem "長3(のりつき)"
End With
'品名プルダウンの初期値
hinmei.ListIndex = 0
Case 3
'レターパックの品目にチェンジ
With hinmei
.AddItem "品名を選択してください"
.AddItem "ラベル"
End With
'品名プルダウンの初期値
hinmei.ListIndex = 0
End Select
End Sub
'userformの初期化
Private Sub UserForm_Initialize()
'UserForm3にカレンダーをオーバーラップさせる
Me.Top = UserForm3.Top + 50
Me.Left = UserForm3.Left + 50
'希望日のプルダウンにカレンダーを被せる
Set DTPCBox2 = New clsDTPickerOnCombo3
With DTPCBox2
.Add kibou
.Create Me, "yyyy/MM/dd(dddd)", DefaultFONT:=False  '2:ComboBox部のみフォント変更
.CalendarBackColor(0) = &H99FFFF           '(1)(2)一緒に設定
.CalendarTitleBackColor(0) = &H808000      '    〃
.CalendarTrailingForeColor(0) = &H99FFFF   '    〃
'.Value(2) = DateValue(Date)
End With
'品目名プルダウンを初期化
With hinmoku
If .Text = "" Then
.AddItem "品目名を選択してください"
.AddItem "レターパック"
.AddItem "封筒"
.AddItem "ラベル印刷"
End If
End With
hinmoku.ListIndex = 0
End Sub
Private Sub UserForm_Terminate()
DTPCBox2.Destroy
Set DTPCBox2 = Nothing
End Sub
'メールアドレスの形式チェック
Function chkMailAddress(mailaddress As Variant) As Boolean
Dim ret     As Boolean      '// 関数戻り値
Dim reg     As New RegExp   '// 正規表現クラスオブジェクト
'// 検索条件＝メールアドレス形式を抽出
reg.Pattern = "^.+@.+\..+$"
'// 文字列の最後まで検索する
reg.Global = True
If reg.Test(mailaddress) = False Then
chkMailAddress = False
Exit Function
End If
chkMailAddress = True
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

Option Explicit

Private DTPCBox2 As clsDTPickerOnCombo3

'新規追加ボタンクリック時

Private Sub CommandButton1_Click()

'入力値のvalidationを行う

Dim validata As Variant

Dim ret As Variant

'依頼日を生成する

Dim iraibi As String

iraibi = Format(Date, "yyyy-mm-dd")

dataArray(0) = iraibi

'品目名について

validata = hinmoku.Value

If validata = "" Or validata = "品目名を選択してください" Then

MsgBox "品目名が選択されていませんよ"

hinmoku.SetFocus

Exit Sub

Else

dataArray(1) = validata

End If

'品名について

validata = hinmei.Value

If validata = "" Or validata = "品名を選択してください" Then

MsgBox "品名が選択されていませんよ"

hinmei.SetFocus

Exit Sub

Else

dataArray(2) = validata

End If

'数量について

validata = StrConv(suryou.Value, vbNarrow)

If validata = "" Or validata = 0 Then

MsgBox "数量が入っていません"

suryou.SetFocus

Exit Sub

Else

'入力値が数値かどうか判定

If IsNumeric(validata) Then

dataArray(3) = validata

Else

MsgBox "数値じゃない値が入っていますよ"

suryou.SetFocus

Exit Sub

End If

'希望日について

validata = DTPCBox2.Value

dataArray(4) = Replace(validata, "/", "-")

'コードについて

validata = StrConv(pjcode.Value, vbNarrow)

If validata = "" Then

MsgBox "コードが入っていませんよ"

pjcode.SetFocus

Exit Sub

Else

dataArray(5) = validata

End If

'担当者について

validata = tantou.Value

If validata = "" Then

MsgBox "担当者名が入っていませんよ"

tantou.SetFocus

Exit Sub

Else

dataArray(6) = validata

End If

'メールアドレスについて

validata = StrConv(mail.Value, vbNarrow)

If validata = "" Then

MsgBox "メールアドレスが入っていませんよ"

mail.SetFocus

Exit Sub

Else

'有効なメールアドレス形式のチェック

If chkMailAddress(validata) Then

dataArray(7) = validata

Else

MsgBox "有効なメールアドレスの形式ではありません"

mail.SetFocus

Exit Sub

End If

'毎月の場合について

validata = monthman.Value

dataArray(8) = validata

'使用用途について

validata = youto.Value

If validata = "" Then

MsgBox "使用用途が入っていませんよ"

youto.SetFocus

Exit Sub

Else

dataArray(9) = validata

End If

'kintone側へデータをインサート

ret = kintoneInsert()

'retの値によって、処理を分岐

If ret = True Then

'データを再取得する

Call kintoneGetdata

'UserForm3をアンロード

Unload UserForm3

Else

'追加失敗してるので何もしない

End If

End Sub

'品目名プルダウン選択時

Private Sub hinmoku_Change()

'ListIndexの値に応じて変更

Dim listnum As Integer

listnum = hinmoku.ListIndex

'品名プルダウンをクリアする

hinmei.Clear

'選択項目に応じて品名プルダウンを変更

Select Case listnum

Case 0

'何もしない

Case 1

'レターパックの品目にチェンジ

With hinmei

.AddItem "品名を選択してください"

.AddItem "レターパックプラス"

.AddItem "レターパックライト"

End With

'品名プルダウンの初期値

hinmei.ListIndex = 0

Case 2

'封筒の品目にチェンジ

With hinmei

.AddItem "品名を選択してください"

.AddItem "角2"

.AddItem "角2(のりつき)"

.AddItem "コピー用紙"

.AddItem "コピー用紙(1箱)"

.AddItem "長3(のりつき)"

End With

'品名プルダウンの初期値

hinmei.ListIndex = 0

Case 3

'レターパックの品目にチェンジ

With hinmei

.AddItem "品名を選択してください"

.AddItem "ラベル"

End With

'品名プルダウンの初期値

hinmei.ListIndex = 0

End Select

End Sub

'userformの初期化

Private Sub UserForm_Initialize()

'UserForm3にカレンダーをオーバーラップさせる

Me.Top = UserForm3.Top + 50

Me.Left = UserForm3.Left + 50

'希望日のプルダウンにカレンダーを被せる

Set DTPCBox2 = New clsDTPickerOnCombo3

With DTPCBox2

.Add kibou

.Create Me, "yyyy/MM/dd(dddd)", DefaultFONT:=False '2:ComboBox部のみフォント変更

.CalendarBackColor(0) = &H99FFFF '(1)(2)一緒に設定

.CalendarTitleBackColor(0) = &H808000 ' 〃

.CalendarTrailingForeColor(0) = &H99FFFF ' 〃

'.Value(2) = DateValue(Date)

End With

'品目名プルダウンを初期化

With hinmoku

If .Text = "" Then

.AddItem "品目名を選択してください"

.AddItem "レターパック"

.AddItem "封筒"

.AddItem "ラベル印刷"

End If

End With

hinmoku.ListIndex = 0

End Sub

Private Sub UserForm_Terminate()

DTPCBox2.Destroy

Set DTPCBox2 = Nothing

End Sub

'メールアドレスの形式チェック

Function chkMailAddress(mailaddress As Variant) As Boolean

Dim ret As Boolean '// 関数戻り値

Dim reg As New RegExp '// 正規表現クラスオブジェクト

'// 検索条件＝メールアドレス形式を抽出

reg.Pattern = "^.+@.+\..+$"

'// 文字列の最後まで検索する

reg.Global = True

If reg.Test(mailaddress) = False Then

chkMailAddress = False

Exit Function

End If

chkMailAddress = True

End Function

initializeではkibouという名前の希望日プルダウン上にDTPickerを呼び出して被せています（kibouのプルダウンはダミーなので、値を取る時には、DTPCBox2.valueとしてこの場合取得します。
同じく、品目名のプルダウンの初期化を行い、初期値はListIndex = 0のものを指定しています。
品目名プルダウンを選択した時のchangeイベントにて品名プルダウンを生成し、初期値はListIndex = 0のものを指定しています。
新規追加ボタンでは各コントロールの値を取得・Validationを行い、グローバル配列であるdataArray()に追加しています。
kintoneInsertを呼び出し、無事に追加が出来た場合には、kintoneGetdataを呼び出して最新のデータを取得させています。
メールアドレスの形式チェックではこちらのサイトの関数を利用しています。

メインの追加用コード

データの新規追加は更新のコードと殆ど同じです。ただ、レコード番号の指定が無いだけですね。

'kintoneへレコードを追加する（単一レコード）
Public Function kintoneInsert() As Boolean
'変数の宣言
Dim appid As String
Dim access_token As String
Dim temptoken As String
Dim ret As Variant
'APP IDを取得する
appid = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"appid", _
REG_SZ, _
0)
'アクセストークンの期限切れチェック
actflg = checkExpireToken()
If actflg = False Then
'新しくトークンを取得し直す
ret = getNewToken()
'トークンが取得し直せたか判定
If ret = False Then
MsgBox "Access Tokenの再取得に失敗しました。再度認証し直してください。"
Exit Function
End If
End If
'アクセストークンを取り出す
temptoken = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"access_token", _
REG_SZ, _
0)
access_token = aes128decode(temptoken)
'リクエストデータを組み立て
Dim Json_St As String
Dim Json As New Scripting.Dictionary  '外側のJSON用
Dim Rec_Json As New Scripting.Dictionary 'record用
'共通値を追加
Json.Add "app", CInt(appid) 'appIDを指定
'個別フィールド用
Dim json_iraibi As New Scripting.Dictionary '依頼日用
Dim json_hinmoku As New Scripting.Dictionary '品目名用
Dim json_hinmei As New Scripting.Dictionary '品名用
Dim json_suryou As New Scripting.Dictionary '数量用
Dim json_kibou As New Scripting.Dictionary '希望日用
Dim json_pjcode As New Scripting.Dictionary 'コード用
Dim json_tantou As New Scripting.Dictionary '担当者名用
Dim json_mail As New Scripting.Dictionary 'メアド用
Dim json_monthman As New Scripting.Dictionary '毎月の場合用
Dim json_youto As New Scripting.Dictionary '使用用途用
'各列のデータを生成して1レコード作る
json_iraibi.Add "value", dataArray(0)
json_hinmoku.Add "value", dataArray(1)
json_hinmei.Add "value", dataArray(2)
json_suryou.Add "value", dataArray(3)
json_kibou.Add "value", dataArray(4)
json_pjcode.Add "value", dataArray(5)
json_tantou.Add "value", dataArray(6)
json_mail.Add "value", dataArray(7)
json_monthman.Add "value", dataArray(8)
json_youto.Add "value", dataArray(9)
With Rec_Json
.Add "依頼日", json_iraibi
.Add "品目名", json_hinmoku
.Add "品名", json_hinmei
.Add "数量", json_suryou
.Add "希望日", json_kibou
.Add "コード", json_pjcode
.Add "担当者", json_tantou
.Add "メールアドレス", json_mail
.Add "毎月の場合", json_monthman
.Add "使用用途", json_youto
End With
'recordに塊を追加する
Json.Add "record", Rec_Json
'JSONに変換
Json_St = JsonConverter.ConvertToJson(Json)
'HTTPリクエスト
Dim http As New WinHttpRequest
Dim flagman As Boolean
With http
.Open "POST", kinputdata, False
.setProxy 2, proxyuri  'プロキシサーバのURLとポート番号
.setRequestHeader "Content-Type", "application/json"
.setRequestHeader "Authorization", "Bearer " & access_token
.Send Json_St
'ステータスを取得
Dim status As String
status = .status
Select Case .status
Case 200, 201
'JSON取得用
Dim doc, jsn, Jsonman
Dim tempjson, temprec, tempval
'HTMLDocumentを取得
Set doc = CreateObject("HtmlFile")
'scriptタグを追加
doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
'JSONデータを取得する
Jsonman = .responseText
'パース関数でJSONオブジェクトを取得
Set jsn = doc.JsonParse(Jsonman)
'レコード番号を取得する
recid = CallByName(jsn, "id", VbGet)
flagman = True
Case Else
MsgBox .status & "エラー。データの追加は失敗しました。"
flagman = False
End Select
End With
'値を返す
kintoneInsert = flagman
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

'kintoneへレコードを追加する（単一レコード）

Public Function kintoneInsert() As Boolean

'変数の宣言

Dim appid As String

Dim access_token As String

Dim temptoken As String

Dim ret As Variant

'APP IDを取得する

appid = RegGetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"appid", _

REG_SZ, _

'アクセストークンの期限切れチェック

actflg = checkExpireToken()

If actflg = False Then

'新しくトークンを取得し直す

ret = getNewToken()

'トークンが取得し直せたか判定

If ret = False Then

MsgBox "Access Tokenの再取得に失敗しました。再度認証し直してください。"

Exit Function

End If

'アクセストークンを取り出す

temptoken = RegGetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"access_token", _

REG_SZ, _

access_token = aes128decode(temptoken)

'リクエストデータを組み立て

Dim Json_St As String

Dim Json As New Scripting.Dictionary '外側のJSON用

Dim Rec_Json As New Scripting.Dictionary 'record用

'共通値を追加

Json.Add "app", CInt(appid) 'appIDを指定

'個別フィールド用

Dim json_iraibi As New Scripting.Dictionary '依頼日用

Dim json_hinmoku As New Scripting.Dictionary '品目名用

Dim json_hinmei As New Scripting.Dictionary '品名用

Dim json_suryou As New Scripting.Dictionary '数量用

Dim json_kibou As New Scripting.Dictionary '希望日用

Dim json_pjcode As New Scripting.Dictionary 'コード用

Dim json_tantou As New Scripting.Dictionary '担当者名用

Dim json_mail As New Scripting.Dictionary 'メアド用

Dim json_monthman As New Scripting.Dictionary '毎月の場合用

Dim json_youto As New Scripting.Dictionary '使用用途用

'各列のデータを生成して1レコード作る

json_iraibi.Add "value", dataArray(0)

json_hinmoku.Add "value", dataArray(1)

json_hinmei.Add "value", dataArray(2)

json_suryou.Add "value", dataArray(3)

json_kibou.Add "value", dataArray(4)

json_pjcode.Add "value", dataArray(5)

json_tantou.Add "value", dataArray(6)

json_mail.Add "value", dataArray(7)

json_monthman.Add "value", dataArray(8)

json_youto.Add "value", dataArray(9)

With Rec_Json

.Add "依頼日", json_iraibi

.Add "品目名", json_hinmoku

.Add "品名", json_hinmei

.Add "数量", json_suryou

.Add "希望日", json_kibou

.Add "コード", json_pjcode

.Add "担当者", json_tantou

.Add "メールアドレス", json_mail

.Add "毎月の場合", json_monthman

.Add "使用用途", json_youto

End With

'recordに塊を追加する

Json.Add "record", Rec_Json

'JSONに変換

Json_St = JsonConverter.ConvertToJson(Json)

'HTTPリクエスト

Dim http As New WinHttpRequest

Dim flagman As Boolean

With http

.Open "POST", kinputdata, False

.setProxy 2, proxyuri 'プロキシサーバのURLとポート番号

.setRequestHeader "Content-Type", "application/json"

.setRequestHeader "Authorization", "Bearer " & access_token

.Send Json_St

'ステータスを取得

Dim status As String

status = .status

Select Case .status

Case 200, 201

'JSON取得用

Dim doc, jsn, Jsonman

Dim tempjson, temprec, tempval

'HTMLDocumentを取得

Set doc = CreateObject("HtmlFile")

'scriptタグを追加

doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"

'JSONデータを取得する

Jsonman = .responseText

'パース関数でJSONオブジェクトを取得

Set jsn = doc.JsonParse(Jsonman)

'レコード番号を取得する

recid = CallByName(jsn, "id", VbGet)

flagman = True

Case Else

MsgBox .status & "エラー。データの追加は失敗しました。"

flagman = False

End Select

End With

'値を返す

kintoneInsert = flagman

End Function

レコードの塊はそれぞれの列用にDictionaryを用意し、valueをセット、Rec_Jsonに追加する形でJsonConverter.ConvertToJsonを行ってから、JSON形式に仕立てています。
JSON化したデータを元に、WinHttpにてPOSTで通信をしています。
無事にデータが追加できたら、200が返ってくるので、flagmanにフラグを格納して返します。
今回はシンプルなフォームなのでこんなもんですが、checkboxなどの場合や、複数のレコードをまとめてバルクインサートなどはまたやり方が異なるので、難易度が上です。
組み立てたJSONは以下のような感じになります。
Kintone側からの返り値をCallbyNameで取得すると、新規追加時に割り当てられたレコード番号を取得することが可能です。今回はこの値をrecidに格納しています。

{
"app":999,
"record":{
"依頼日":{
"value":"2020-03-18"
},
"品目名":{
"value":"ここに品目プルダウンの値"
},
"品名":{
"value":"ここに品名プルダウンの値"
},
：：：中略：：：
"毎月の場合":{
"value":"毎月使いたい場合のコメント"
},
"使用用途":{
"value":"使用用途について"
}
}
}

{

"app":999,

"record":{

"依頼日":{

"value":"2020-03-18"

"品目名":{

"value":"ここに品目プルダウンの値"

"品名":{

"value":"ここに品名プルダウンの値"

：：：中略：：：

"毎月の場合":{

"value":"毎月使いたい場合のコメント"

"使用用途":{

"value":"使用用途について"

}

データの削除

Excel上でレコードの削除をしても、kintone上で削除されるわけじゃありません。ですので、レコード削除用のコマンドを用意し、それを持って削除をするようにしましょう。未処理のままの行をただExcel上で削除しても次回データ取得時に当然ですが復活してしまいますので、データの削除は必須です。kintoneの仕様上1度に削除できる件数は最大100件までです。

'kintoneからデータを削除するコマンド
Public Function kintoneDelete()
'現在アクティブになってるシート名を取得する
Dim activesheetman As String
activesheetman = ActiveSheet.Name
'// シートの入力範囲の全セルを取得
Dim rUsed As Range
Set rUsed = ActiveSheet.UsedRange
'行選択されているかどうかチェック
Dim lineman As Boolean
lineman = line_check()
If lineman = False Then
'行選択されていないので終了
MsgBox "行選択されていませんよ"
Exit Function
End If
'選択されている行数が2以上の場合終了
If Selection.Rows.Count >= 2 Then
MsgBox "一度に選択できる行数は1行だけです。"
Exit Function
End If
'選択されている行番号を取得する
Dim rng As Range
For Each rng In Selection.Rows
selerec = rng.Row
Next rng
'レコードデータIDを取得する
tarrec = rUsed(selerec, 1)
'レコードIDが空の場合終了
If tarrec = "" Then
MsgBox "有効な行が選択されていません。"
Exit Function
End If
'問い合わせを出す
Dim result As Variant
result = MsgBox("kintoneから『ID=" & tarrec & "』のデータを削除しますか？？", vbYesNo + vbDefaultButton2 + vbExclamation)
If result = vbYes Then
'インポート処理を続行する
Else
'メッセージを表示
MsgBox "処理をキャンセルしました。"
'終了処理
Exit Function
End If
'承認作業を実行
Dim ret As Boolean
ret = kintoneDelData()
'retの値によって、処理を分岐
If ret = True Then
'行を削除する
ThisWorkbook.Worksheets("kintone").Rows(selerec).Delete
'削除完了
MsgBox "データは削除されました。"
Else
'削除失敗してるので何もしない
End If
End Function
'レコード削除を担当する関数
Public Function kintoneDelData() As Boolean
'変数の宣言
Dim appid As String
Dim access_token As String
Dim temptoken As String
Dim ret As Variant
'APP IDを取得する
appid = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"appid", _
REG_SZ, _
0)
'アクセストークンの期限切れチェック
actflg = checkExpireToken()
If actflg = False Then
'新しくトークンを取得し直す
ret = getNewToken()
'トークンが取得し直せたか判定
If ret = False Then
MsgBox "Access Tokenの再取得に失敗しました。再度認証し直してください。"
Exit Function
End If
End If
'アクセストークンを取り出す
temptoken = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"access_token", _
REG_SZ, _
0)
access_token = aes128decode(temptoken)
'リクエストURLを構築する
Dim requrl As String
requrl = kingetdata & "?app=" & appid & "&ids[0]=" & tarrec
'HTTPリクエスト
Dim http As New WinHttpRequest
Dim flagman As Boolean
'kintoneへデータをリクエスト
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "DELETE", requrl, False
.setProxy 2, proxyuri  'プロキシサーバのURLとポート番号
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Authorization", "Bearer " & access_token
.Send
'ステータスを取得
Dim status As String
status = .status
Select Case .status
Case 200, 201
flagman = True
Case Else
MsgBox .status & "エラー。削除は失敗しました。"
flagman = False
End Select
End With
'値を返す
kintoneDelData = flagman
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

'kintoneからデータを削除するコマンド

Public Function kintoneDelete()

'現在アクティブになってるシート名を取得する

Dim activesheetman As String

activesheetman = ActiveSheet.Name

'// シートの入力範囲の全セルを取得

Dim rUsed As Range

Set rUsed = ActiveSheet.UsedRange

'行選択されているかどうかチェック

Dim lineman As Boolean

lineman = line_check()

If lineman = False Then

'行選択されていないので終了

MsgBox "行選択されていませんよ"

Exit Function

End If

'選択されている行数が2以上の場合終了

If Selection.Rows.Count >= 2 Then

MsgBox "一度に選択できる行数は1行だけです。"

Exit Function

End If

'選択されている行番号を取得する

Dim rng As Range

For Each rng In Selection.Rows

selerec = rng.Row

Next rng

'レコードデータIDを取得する

tarrec = rUsed(selerec, 1)

'レコードIDが空の場合終了

If tarrec = "" Then

MsgBox "有効な行が選択されていません。"

Exit Function

End If

'問い合わせを出す

Dim result As Variant

result = MsgBox("kintoneから『ID=" & tarrec & "』のデータを削除しますか？？", vbYesNo + vbDefaultButton2 + vbExclamation)

If result = vbYes Then

'インポート処理を続行する

Else

'メッセージを表示

MsgBox "処理をキャンセルしました。"

'終了処理

Exit Function

End If

'承認作業を実行

Dim ret As Boolean

ret = kintoneDelData()

'retの値によって、処理を分岐

If ret = True Then

'行を削除する

ThisWorkbook.Worksheets("kintone").Rows(selerec).Delete

'削除完了

MsgBox "データは削除されました。"

Else

'削除失敗してるので何もしない

End If

End Function

'レコード削除を担当する関数

Public Function kintoneDelData() As Boolean

'変数の宣言

Dim appid As String

Dim access_token As String

Dim temptoken As String

Dim ret As Variant

'APP IDを取得する

appid = RegGetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"appid", _

REG_SZ, _

'アクセストークンの期限切れチェック

actflg = checkExpireToken()

If actflg = False Then

'新しくトークンを取得し直す

ret = getNewToken()

'トークンが取得し直せたか判定

If ret = False Then

MsgBox "Access Tokenの再取得に失敗しました。再度認証し直してください。"

Exit Function

End If

'アクセストークンを取り出す

temptoken = RegGetValue(HKEY_CURRENT_USER, _

"Software\kintoneman" & _

"\Settings", _

"access_token", _

REG_SZ, _

access_token = aes128decode(temptoken)

'リクエストURLを構築する

Dim requrl As String

requrl = kingetdata & "?app=" & appid & "&ids[0]=" & tarrec

'HTTPリクエスト

Dim http As New WinHttpRequest

Dim flagman As Boolean

'kintoneへデータをリクエスト

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open "DELETE", requrl, False

.setProxy 2, proxyuri 'プロキシサーバのURLとポート番号

.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

.setRequestHeader "Authorization", "Bearer " & access_token

.Send

'ステータスを取得

Dim status As String

status = .status

Select Case .status

Case 200, 201

flagman = True

Case Else

MsgBox .status & "エラー。削除は失敗しました。"

flagman = False

End Select

End With

'値を返す

kintoneDelData = flagman

End Function

kingetdataのエンドポイントURLを使用します。
一括削除が出来ますが今回は1レコード削除にしてあります。複数行削除したい場合にはids配列を複数つなげればOKです（ids[0]=1&ids[1]=3といった具合に）
idsに代入する値はレコードIDです。
WinHttpで通信するときのメソッドは「DELETE」になります。
削除が成功すると200のステータスが返ってくるので、これを受信したら、Excelシート側の行をRows(レコード番号).Deleteで削除します。レコードのIDではなくレコード番号な点に注意。
次項にあるように、右クリックメニューから削除できるようにコマンドを追加しておくと非常に便利です

右クリックメニューにも承認ボタンを付ける

リボンにすでに承認用ボタンを付けているので、不要といえば不要なのですが、マウス操作では行選択=>即承認作業という流れでは、リボンまでの移動やボタンを選ぶ作業は地味にタイムロスやストレスになります。そこで、右クリックメニューにも承認用ボタンをつけてみます。起動時に自動的にメニューへ動的に追加します。

'リボン起動時に初期化するコード
Public Sub OnLoad(ribbon As IRibbonUI)
'リボンのインスタンスを取得
Set m_ribbon = ribbon
'自作のリボンをアクティブにする
m_ribbon.ActivateTab ("macroman")
'右クリックメニューを一時的に追加する
Dim approve
Set approve = Application.CommandBars("row").Controls.Add(Temporary:=True)
With approve
.Caption = "承認作業"
.OnAction = "kintoneApprove"
.BeginGroup = "False"
.FaceId = 2
End With
End Sub

'リボン起動時に初期化するコード

Public Sub OnLoad(ribbon As IRibbonUI)

'リボンのインスタンスを取得

Set m_ribbon = ribbon

'自作のリボンをアクティブにする

m_ribbon.ActivateTab ("macroman")

'右クリックメニューを一時的に追加する

Dim approve

Set approve = Application.CommandBars("row").Controls.Add(Temporary:=True)

With approve

.Caption = "承認作業"

.OnAction = "kintoneApprove"

.BeginGroup = "False"

.FaceId = 2

End With

End Sub

リボンのOnLoadイベントを今回は利用しています。Auto_OpenのサブプロシージャでもOK
今回は単一のボタン追加ですが、ネストするサブメニュー追加も可能です。また、ボタンの位置なども変更可能
Temporary:=Trueは付けておいたほうが良いです。ブック終了時にメニューが消えます。でないと、次回起動時にもう一個メニューが追加されてしまうため
Application.CommandBars("cell")でセルの右クリックメニューになります。今回は行選択なのでrowを指定しています。
Application.CommandBars("row").Control("コマンド名").Deleteでメニューを削除可能。コマンド名はCaptionで指定した文字列です。
faceidはアイコンです。番号で指定をします。こちらのサイトに対応表があるので、好きなアイコンを指定しましょう。

図：承認作業メニューが追加されました

VBAからkintoneデータをOAuth2.0認証で読み書きする - 実戦編

今回使用するファイル等

新方式が登場しました

事前準備

参照設定

APP IDの取得と保存

シート側の列の設定

承認用のフォームを用意する

新規追加用フォーム

ソースコード

データの一括取得

全データを取得する

データの更新

承認フォーム側コード

メインの更新用コード

データの新規追加

新規追加フォーム側コード

メインの追加用コード

データの削除

右クリックメニューにも承認ボタンを付ける

関連リンク

コメントを残すコメントをキャンセル

VBAからkintoneデータをOAuth2.0認証で読み書きする - 準備編

Puppeteerでウェブサイトをスクレイピング

今回使用するファイル等

新方式が登場しました

事前準備

参照設定

APP IDの取得と保存

シート側の列の設定

承認用のフォームを用意する

新規追加用フォーム

ソースコード

データの一括取得

全データを取得する

データの更新

承認フォーム側コード

メインの更新用コード

データの新規追加

新規追加フォーム側コード

メインの追加用コード

データの削除

右クリックメニューにも承認ボタンを付ける

関連リンク

コメントを残す コメントをキャンセル

VBAからkintoneデータをOAuth2.0認証で読み書きする - 準備編

Puppeteerでウェブサイトをスクレイピング

コメントを残すコメントをキャンセル