Attribute VB_Name = "Module1" Option Explicit '共通変数 Public 事業計画テーブルID As String Public apiKey As String Public baseURL As String Public 年度 As String Public エクスポート1 As String Public エクスポート2 As String '処理開始 Sub run() Debug.Print "------ START ------" '実行確認 Dim rc As VbMsgBoxResult rc = MsgBox("プリザンターから最新の事業計画データを取得しますか？" & Chr(13) & "この処理には少々時間が掛かります", vbYesNo + vbQuestion) If rc = vbYes Then Worksheets("実行度合表集計").Cells(1, 9) = "取得処理中..." Application.ScreenUpdating = False '画面更新停止 Application.Calculation = xlManual '自動計算停止 '初期化 Call init '事業計画データ取得１ Dim resCSV As Variant resCSV = 事業計画CSVエクスポート(エクスポート1 & "") 'CSVデータをシートに保存 Call CSVデータ保存1(resCSV, 事業計画テーブルID & "") '事業計画データ取得２ resCSV = 事業計画CSVエクスポート(エクスポート2 & "") 'CSVデータをシートに保存 Call CSVデータ保存2(resCSV) 'Worksheets("実行度合表集計").Range("B2").Select Worksheets("実行度合表集計").Cells(1, 9) = "取得完了" Application.Calculation = xlAutomatic '自動計算開始 Application.ScreenUpdating = True '画面更新開始 Else MsgBox "処理を中止します", vbCritical End If Debug.Print "------ " Debug.Print "------ END ------" End Sub Function init() 'パブリック変数に値を格納 '事業計画テーブル 214737 事業計画テーブルID = Range("事業計画テーブルID").Value 年度 = Range("年度").Value エクスポート1 = Range("エクスポート1").Value エクスポート2 = Range("エクスポート2").Value 'Pleasanter API KEY apiKey = "6504c8a807677a3a576e10327f3c19876c55736ee45d4a845796b9e7f5e087bfd4bd0d8184863da8cf1733ca635111432ab334aea59102b06a96ee6d2c05190d" baseURL = "https://nextoffice.Next-hd.co.jp" End Function Function 事業計画CSVエクスポート(exportId As String) As Variant '共通変数 Dim apiUrl As String Dim apiUrlParam As String 'リクエストURL apiUrl = baseURL & "/pleasanter/api/items/" & 事業計画テーブルID & "/" apiUrlParam = "export" 'ヘッダ Dim apiHeaders As New Dictionary apiHeaders.Add "Content-Type", "application/json;charset=utf-8" 'リクエストデータ Dim apiBody As New Dictionary apiBody.Add "ApiVersion", "1.1" apiBody.Add "ApiKey", apiKey apiBody.Add "ExportId", exportId 'Filter変数 Dim colFilter As New Dictionary colFilter.Add "ClassZ", "[" & 年度 & "]" 'ソート指定 Dim colSorter As New Dictionary colSorter.Add "Num199", "asc" colSorter.Add "ClassA", "asc" colSorter.Add "ClassB", "asc" 'View変数 Dim view As New Dictionary view.Add "ColumnFilterHash", colFilter view.Add "ColumnSorterHash", colSorter apiBody.Add "View", view 'HTTPリクエスト送信メソッド呼び出し Dim res As Object Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody) If res("StatusCode") = 200 Then Debug.Print "---- CSVデータの取得に成功しました" 事業計画CSVエクスポート = res("Response")("Content") End If End Function Function CSVデータ保存1(csvData As Variant, targetSheet As String) Debug.Print "------ CSVデータをシートに出力開始" 'CSVデータを「テーブル」部分に出力する処理 Dim ws As Worksheet Set ws = ThisWorkbook.Sheets(targetSheet & "") ws.Cells.ClearContents Dim lines() As String lines = Split(csvData, vbCrLf) Dim i As Long, j As Long Dim maxCols As Long Dim values() As String Dim arr() As Variant 'まず最大列数を取得 For i = LBound(lines) To UBound(lines) If Trim(lines(i)) <> "" Then values = Split(lines(i), ",") If UBound(values) + 1 > maxCols Then maxCols = UBound(values) + 1 End If End If Next i '二次元配列を初期化 ReDim arr(0 To UBound(lines), 0 To maxCols - 1) '配列に格納 For i = LBound(lines) To UBound(lines) If Trim(lines(i)) <> "" Then values = Split(lines(i), ",") For j = LBound(values) To UBound(values) arr(i, j) = values(j) Next j End If Next i 'シートに出力 ws.Range(ws.Cells(1, 1), ws.Cells(UBound(arr, 1) + 1, UBound(arr, 2) + 1)).Value = arr Debug.Print "------ " Debug.Print "------ CSVデータをシートに出力完了" End Function Function CSVデータ保存2(csvData As Variant) Debug.Print "------ CSVデータを店舗別シートに出力開始" Dim lines() As String lines = Split(csvData, vbCrLf) Dim i As Long, j As Long For i = LBound(lines) To UBound(lines) If Trim(lines(i)) <> "" Then Call シート作成処理(lines(i)) Call データシート保存(lines(i)) End If Next i Debug.Print "------ " Debug.Print "------ CSVデータを店舗別シートに出力完了" End Function Function シート作成処理(data As String) Dim values() As String values = Split(data, vbTab) Dim 店舗名 As String 店舗名 = values(1) Dim 種別 As String 種別 = values(2) '各シート存在確認 Dim 受着完シートExist As Boolean Dim 損益シートExist As Boolean Dim DATAシートExist As Boolean 受着完シートExist = シート確認(店舗名 & "_受着完") 損益シートExist = シート確認(店舗名 & "_損益") DATAシートExist = シート確認(店舗名 & "_DATA") 'シート作成 If 受着完シートExist = False Then If 種別 = "1" Then Worksheets("受着完テンプレート2").Copy After:=Worksheets(Worksheets.count) Else Worksheets("受着完テンプレート1").Copy After:=Worksheets(Worksheets.count) End If ActiveSheet.Name = 店舗名 & "_受着完" ActiveSheet.Range("A1") = 店舗名 If 種別 = "" Then ActiveSheet.Range("A3") = "False" Else ActiveSheet.Range("A3") = "True" End If End If If 損益シートExist = False Then Worksheets("損益テンプレート").Copy After:=Worksheets(店舗名 & "_受着完") ActiveSheet.Name = 店舗名 & "_損益" ActiveSheet.Range("A1") = 店舗名 If 種別 = "" Then ActiveSheet.Range("A3") = "False" Else ActiveSheet.Range("A3") = "True" End If End If If DATAシートExist = False Then Worksheets("DATAテンプレート").Copy After:=Worksheets(店舗名 & "_損益") ActiveSheet.Name = 店舗名 & "_DATA" 'ActiveSheet.Visible = False End If End Function Function データシート保存(data As String) Dim values() As String values = Split(data, vbTab) Dim 店舗名 As String 店舗名 = values(1) Dim ws As Worksheet Set ws = ThisWorkbook.Sheets(店舗名 & "_DATA") 'シートをクリア 'ws.Visible = True 'ws.Select ws.Range("C4:CG68").ClearContents 'データをシートに保存 Dim num As Long , i As Long, j As Long, x As Long, y As Long Dim dataStr As String Dim dataObj As Object num = 3 Dim arrData() As Variant ReDim arrData(1 To 65, 1 To 83) x = 1 y = 1 For i = 1 To 6 For j = 1 To 12 dataStr = values(num) Set dataObj = JsonConverter.ParseJson(dataStr) Dim var, y1 As Long, x1 As Long y1 = y x1 = x For Each var In dataObj 'Debug.Print "VAR1:" & var("1") , "VAR2:" & var("2") , "VAR3:" & var("3") , "VAR4:" & var("4") , "VAR6:" & var("6") , "VAR7:" & var("7") arrData(x, y) = 日付変換(var("1")) y = y + 1 arrData(x, y) = var("2") y = y + 1 arrData(x, y) = var("3") y = y + 1 arrData(x, y) = var("4") y = y + 1 arrData(x, y) = var("6") y = y + 1 arrData(x, y) = var("7") y = y1 x = x + 1 Next var y = y1 + 7 x = x1 num = num + 1 Next j y = 1 x = x + 11 Next i 'データの書き込み ws.Range("C4").Resize(UBound(arrData, 1), UBound(arrData, 2)).Value = arrData 'Debug.Print "---- " & 店舗名 & " のDATAシートにデータを保存します" ws.Visible = False End Function