a60244b7b0
Excelのテーブル(ListObject)は、直前と同一サイズへのResizeを行うとDataBodyRangeの内部状態が更新されないことがあり、 データ行数が変わらない場合(前回0件クリア後に1件だけ取得した場合など)にDataBodyRange.Value代入が効かず、 テーブルにデータが書き込まれない不具合があった。 exportCSVDataToSheet/getRecordsDataToSheet/exportCSVDataToExistingTableの3箇所で、 一旦ヘッダ行のみにリサイズしてから目的のサイズにリサイズし直すことで回避。 調査用の詳細デバッグログ([DEBUG] records.count等)も合わせて追加。 Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com>
747 lines
25 KiB
QBasic
747 lines
25 KiB
QBasic
Attribute VB_Name = "Module1"
|
||
Option Explicit
|
||
|
||
Public apiKey As String
|
||
Public baseURL As String
|
||
Public yearFilter As String
|
||
Public tableId As String
|
||
Public defaultSh As Worksheet
|
||
|
||
Function init()
|
||
'Pleasanter API KEY
|
||
apiKey = "6504c8a807677a3a576e10327f3c19876c55736ee45d4a845796b9e7f5e087bfd4bd0d8184863da8cf1733ca635111432ab334aea59102b06a96ee6d2c05190d"
|
||
baseURL = "https://nextoffice.Next-hd.co.jp"
|
||
tableId = Range("着工要因ID")
|
||
|
||
Set defaultSh = ThisWorkbook.Sheets("基本情報")
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
Sub run()
|
||
'初期化処理
|
||
Call init
|
||
|
||
'入力チェック（営業所・物件状況が未選択なら処理中断）
|
||
Dim selSalesOffice As Variant, selPropertyStatus As Variant
|
||
selSalesOffice = Range("選択営業所").Cells(1, 1).Value
|
||
selPropertyStatus = Range("選択状況").Cells(1, 1).Value
|
||
If IsError(selSalesOffice) Then selSalesOffice = ""
|
||
If IsError(selPropertyStatus) Then selPropertyStatus = ""
|
||
|
||
If Trim(CStr(selSalesOffice)) = "" Or Trim(CStr(selPropertyStatus)) = "" Then
|
||
MsgBox "営業所と物件状況は必ず選択してください", vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
On Error GoTo Cleanup
|
||
|
||
defaultSh.Range("D4").Value = Now
|
||
defaultSh.Range("D3").Value = "取込処理中..."
|
||
Application.ScreenUpdating = False '画面更新停止
|
||
Application.Calculation = xlManual '自動計算停止
|
||
'------------------------------------------
|
||
Debug.Print "処理開始"
|
||
|
||
Dim exportSuccess As Boolean
|
||
Dim getSuccess As Boolean
|
||
exportSuccess = runExportFlow()
|
||
getSuccess = runGetFlow()
|
||
|
||
Debug.Print "処理終了"
|
||
'------------------------------------------
|
||
|
||
Cleanup:
|
||
Application.Calculation = xlAutomatic '自動計算再開
|
||
Application.ScreenUpdating = True '画面更新再開
|
||
defaultSh.Range("D5").Value = Now
|
||
defaultSh.Range("D6").Value = (defaultSh.Range("D5").Value - defaultSh.Range("D4").Value) * 86400
|
||
|
||
If Err.Number <> 0 Then
|
||
defaultSh.Range("D3").Value = "取込処理失敗（エラー）: " & Err.Description
|
||
Err.Clear
|
||
ElseIf Not (exportSuccess And getSuccess) Then
|
||
defaultSh.Range("D3").Value = "取込処理失敗（データ取得エラー）"
|
||
Else
|
||
defaultSh.Range("D3").Value = "取込処理完了"
|
||
End If
|
||
End Sub
|
||
|
||
'******************************************************************************
|
||
'Export方式（CSV全件取得）でのデータ取込処理
|
||
'成功時True、データを取得できなかった場合Falseを返す
|
||
Function runExportFlow() As Boolean
|
||
Dim resData As Variant
|
||
Dim t0 As Double, t1 As Double, t2 As Double
|
||
|
||
Debug.Print "データ取得処理開始（Export方式）"
|
||
t0 = Timer
|
||
resData = exportCSVData(tableId)
|
||
t1 = Timer
|
||
Debug.Print " exportCSVData(API通信) 所要時間: " & Format(t1 - t0, "0.000") & "秒"
|
||
|
||
If IsEmpty(resData) Or resData = "" Then
|
||
Debug.Print "データが取得できませんでした"
|
||
runExportFlow = False
|
||
Else
|
||
Call exportCSVDataToSheet(resData, tableId & "E")
|
||
t2 = Timer
|
||
Debug.Print " exportCSVDataToSheet(パース+書込) 所要時間: " & Format(t2 - t1, "0.000") & "秒"
|
||
runExportFlow = True
|
||
End If
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'Get方式（api-record-get-multi）でのデータ取込処理
|
||
'成功時True、データを取得できなかった場合Falseを返す
|
||
Function runGetFlow() As Boolean
|
||
Dim records As Collection
|
||
Dim t0 As Double, t1 As Double, t2 As Double
|
||
|
||
Debug.Print "データ取得処理開始（Get方式）"
|
||
t0 = Timer
|
||
Set records = getRecordsData(tableId)
|
||
t1 = Timer
|
||
Debug.Print " getRecordsData(API通信) 所要時間: " & Format(t1 - t0, "0.000") & "秒"
|
||
|
||
If records Is Nothing Then
|
||
Debug.Print "データが取得できませんでした"
|
||
runGetFlow = False
|
||
Else
|
||
Call getRecordsDataToSheet(records, tableId & "G")
|
||
t2 = Timer
|
||
Debug.Print " getRecordsDataToSheet(書込) 所要時間: " & Format(t2 - t1, "0.000") & "秒"
|
||
runGetFlow = True
|
||
End If
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'CSVデータを取得
|
||
Function exportCSVData(tableId As String, Optional viewObj As Object = Nothing) As Variant
|
||
'共通変数
|
||
Dim apiUrl As String
|
||
Dim apiUrlParam As String
|
||
|
||
'リクエストURL
|
||
apiUrl = baseURL & "/pleasanter/api/items/" & tableId & "/"
|
||
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", "1"
|
||
|
||
If Not viewObj Is Nothing Then
|
||
apiBody.Add "View", viewObj
|
||
End If
|
||
|
||
'HTTPリクエスト送信メソッド呼び出し
|
||
Dim res As Object
|
||
Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody)
|
||
|
||
If res("StatusCode") = 200 Then
|
||
Debug.Print "CSVデータの取得に成功しました"
|
||
exportCSVData = res("Response")("Content")
|
||
|
||
End If
|
||
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'CSVデータをシートに書き込む
|
||
Function exportCSVDataToSheet(csvData As Variant, targetSheet As String)
|
||
Debug.Print "CSVデータをシートに出力開始: " & targetSheet
|
||
'------------------------------------------
|
||
'CSVデータを「テーブル」部分に出力する処理
|
||
Dim ws As Worksheet
|
||
On Error Resume Next
|
||
Set ws = ThisWorkbook.Sheets(targetSheet)
|
||
On Error Goto 0
|
||
|
||
If ws Is Nothing Then
|
||
Debug.Print "シートが存在しないため新規作成: " & targetSheet
|
||
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))
|
||
ws.Name = targetSheet
|
||
End If
|
||
|
||
'CSVデータをテーブルに挿入（ダブルクォート内の改行・カンマに対応したCSVパース）
|
||
Dim i As Long, j As Long
|
||
Dim arr() As Variant
|
||
Dim maxCols As Long
|
||
|
||
Dim rows As Collection
|
||
Set rows = ParseCsv(csvData)
|
||
|
||
If rows.count <= 1 Then
|
||
Debug.Print "データが0件のため、既存テーブルのデータ部分をクリアします: " & targetSheet
|
||
Dim tblEmpty As ListObject
|
||
On Error Resume Next
|
||
Set tblEmpty = ws.ListObjects(targetSheet)
|
||
On Error GoTo 0
|
||
If Not tblEmpty Is Nothing Then
|
||
If Not tblEmpty.DataBodyRange Is Nothing Then
|
||
tblEmpty.DataBodyRange.ClearContents
|
||
End If
|
||
End If
|
||
Exit Function
|
||
End If
|
||
|
||
maxCols = 0
|
||
Dim rowArr As Variant
|
||
For Each rowArr In rows
|
||
If UBound(rowArr) + 1 > maxCols Then
|
||
maxCols = UBound(rowArr) + 1
|
||
End If
|
||
Next rowArr
|
||
|
||
' 二次元配列を初期化
|
||
ReDim arr(0 To rows.count - 1, 0 To maxCols - 1)
|
||
|
||
' 配列に格納
|
||
i = 0
|
||
For Each rowArr In rows
|
||
For j = LBound(rowArr) To UBound(rowArr)
|
||
arr(i, j) = rowArr(j)
|
||
Next j
|
||
i = i + 1
|
||
Next rowArr
|
||
|
||
'テーブル（ListObject）取得
|
||
Dim tbl As ListObject
|
||
On Error Resume Next
|
||
Set tbl = ws.ListObjects(targetSheet)
|
||
On Error Goto 0
|
||
|
||
'ヘッダ行はテーブルの有無に関わらず毎回CSVの1行目(arr(0,*))で更新する（列構成の変更に追従するため）
|
||
Dim headerRange As Range
|
||
Set headerRange = ws.Range("A1").Resize(1, maxCols)
|
||
For j = 0 To maxCols - 1
|
||
headerRange.Cells(1, j + 1).Value = arr(0, j)
|
||
Next j
|
||
|
||
If tbl Is Nothing Then
|
||
Debug.Print "テーブルが存在しないため新規作成: " & targetSheet
|
||
Set tbl = ws.ListObjects.Add(xlSrcRange, headerRange, , xlYes)
|
||
tbl.Name = targetSheet
|
||
End If
|
||
|
||
'テーブルのデータ部分をクリア
|
||
If Not tbl.DataBodyRange Is Nothing Then
|
||
tbl.DataBodyRange.ClearContents
|
||
End If
|
||
|
||
' テーブルにデータを追加（ヘッダ行(arr(0,*))を除いたデータ部分のみをDataBodyRangeに書き込む）
|
||
'直前と同一サイズへのResizeだとExcelがDataBodyRangeの内部状態を更新しないことがあるため、
|
||
'一旦ヘッダ行のみにリサイズしてから目的のサイズにリサイズし直す
|
||
tbl.Resize tbl.Range.Resize(1, maxCols)
|
||
tbl.Resize tbl.Range.Resize(rows.count, maxCols)
|
||
|
||
Dim dataArr() As Variant
|
||
ReDim dataArr(1 To rows.count - 1, 1 To maxCols)
|
||
For i = 1 To rows.count - 1
|
||
For j = 1 To maxCols
|
||
dataArr(i, j) = arr(i, j - 1)
|
||
Next j
|
||
Next i
|
||
tbl.DataBodyRange.Value = dataArr
|
||
|
||
'------------------------------------------
|
||
Debug.Print "CSVデータをシートに出力完了: " & targetSheet
|
||
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'CSV文字列をパースし、行ごとのフィールド配列を格納したCollectionを返す
|
||
'ダブルクォートで囲まれたフィールド内の改行・カンマ・エスケープされた""に対応（RFC4180準拠）
|
||
Private Function ParseCsv(Byval csvText As String) As Collection
|
||
Dim rows As New Collection
|
||
Dim fields As Collection
|
||
Set fields = New Collection
|
||
|
||
Dim field As String
|
||
Dim inQuotes As Boolean
|
||
Dim i As Long, ch As String, nextCh As String
|
||
Dim textLen As Long
|
||
textLen = Len(csvText)
|
||
inQuotes = False
|
||
field = ""
|
||
|
||
i = 1
|
||
Do While i <= textLen
|
||
ch = Mid(csvText, i, 1)
|
||
|
||
If inQuotes Then
|
||
If ch = """" Then
|
||
nextCh = Mid(csvText, i + 1, 1)
|
||
If nextCh = """" Then
|
||
field = field & """"
|
||
i = i + 1
|
||
Else
|
||
inQuotes = False
|
||
End If
|
||
Else
|
||
field = field & ch
|
||
End If
|
||
Else
|
||
Select Case ch
|
||
Case """"
|
||
inQuotes = True
|
||
Case ","
|
||
fields.Add field
|
||
field = ""
|
||
Case vbCr, vbLf
|
||
If ch = vbCr And Mid(csvText, i + 1, 1) = vbLf Then i = i + 1
|
||
fields.Add field
|
||
field = ""
|
||
If Not (fields.count = 1 And fields(1) = "") Then
|
||
rows.Add CollectionToArray(fields)
|
||
End If
|
||
Set fields = New Collection
|
||
Case Else
|
||
field = field & ch
|
||
End Select
|
||
End If
|
||
i = i + 1
|
||
Loop
|
||
|
||
'最終フィールド・行（末尾に改行が無い場合）
|
||
If field <> "" Or fields.count > 0 Then
|
||
fields.Add field
|
||
rows.Add CollectionToArray(fields)
|
||
End If
|
||
|
||
Set ParseCsv = rows
|
||
End Function
|
||
|
||
'Collection（1次元）を0始まりのVariant配列に変換
|
||
Private Function CollectionToArray(Byval col As Collection) As Variant
|
||
Dim arr() As Variant
|
||
ReDim arr(0 To col.count - 1)
|
||
Dim k As Long
|
||
For k = 1 To col.count
|
||
arr(k - 1) = col(k)
|
||
Next k
|
||
CollectionToArray = arr
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'基本情報シート上の「FilterTable」「SorterTable」という名前のExcelテーブル（ListObject）を
|
||
'テーブル名で探して読み取り、APIリクエストのViewパラメータに渡すDictionaryを組み立てる。
|
||
'セルの絶対位置には依存しない（テーブルを移動しても動作する）。各テーブルは1列目=項目名、2列目=値/昇降順とする。
|
||
'Filter・Sorterともに0件の場合はNothingを返す（Viewパラメータ自体を付与しないため）
|
||
'ブック内の全シートを走査し、指定した名前のExcelテーブル(ListObject)を探す。見つからなければNothingを返す
|
||
Function FindListObjectByName(ByVal tblName As String) As ListObject
|
||
Dim sh As Worksheet
|
||
Dim tbl As ListObject
|
||
For Each sh In ThisWorkbook.Worksheets
|
||
On Error Resume Next
|
||
Set tbl = sh.ListObjects(tblName)
|
||
On Error GoTo 0
|
||
If Not tbl Is Nothing Then
|
||
Set FindListObjectByName = tbl
|
||
Exit Function
|
||
End If
|
||
Next sh
|
||
Set FindListObjectByName = Nothing
|
||
End Function
|
||
|
||
Function BuildViewFromSheet() As Object
|
||
Dim colFilter As New Dictionary
|
||
Dim filterTbl As ListObject
|
||
Set filterTbl = FindListObjectByName("FilterTable")
|
||
|
||
If Not filterTbl Is Nothing Then
|
||
If Not filterTbl.DataBodyRange Is Nothing Then
|
||
Dim r As Long
|
||
For r = 1 To filterTbl.DataBodyRange.Rows.count
|
||
Dim filterKey As String
|
||
filterKey = Trim(filterTbl.DataBodyRange.Cells(r, 1).Value)
|
||
If filterKey <> "" Then
|
||
colFilter.Add filterKey, "[" & Chr(34) & CStr(filterTbl.DataBodyRange.Cells(r, 2).Value) & Chr(34) & "]"
|
||
End If
|
||
Next r
|
||
End If
|
||
End If
|
||
|
||
Dim colSorter As New Dictionary
|
||
Dim sorterTbl As ListObject
|
||
Set sorterTbl = FindListObjectByName("SorterTable")
|
||
|
||
If Not sorterTbl Is Nothing Then
|
||
If Not sorterTbl.DataBodyRange Is Nothing Then
|
||
Dim r2 As Long
|
||
For r2 = 1 To sorterTbl.DataBodyRange.Rows.count
|
||
Dim sorterKey As String
|
||
sorterKey = Trim(sorterTbl.DataBodyRange.Cells(r2, 1).Value)
|
||
If sorterKey <> "" Then
|
||
colSorter.Add sorterKey, sorterTbl.DataBodyRange.Cells(r2, 2).Value
|
||
End If
|
||
Next r2
|
||
End If
|
||
End If
|
||
|
||
If colFilter.count = 0 And colSorter.count = 0 Then
|
||
Set BuildViewFromSheet = Nothing
|
||
Exit Function
|
||
End If
|
||
|
||
Dim viewObj As New Dictionary
|
||
If colFilter.count > 0 Then
|
||
viewObj.Add "ColumnFilterHash", colFilter
|
||
End If
|
||
If colSorter.count > 0 Then
|
||
viewObj.Add "ColumnSorterHash", colSorter
|
||
End If
|
||
|
||
Set BuildViewFromSheet = viewObj
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'Get方式（api-record-get-multi）でレコードを取得する
|
||
'成功時、レコードDictionaryのCollection(Response.Data)を返す
|
||
Function getRecordsData(tableId As String) As Collection
|
||
Dim apiUrl As String
|
||
Dim apiUrlParam As String
|
||
|
||
apiUrl = baseURL & "/pleasanter/api/items/" & tableId & "/"
|
||
apiUrlParam = "get"
|
||
|
||
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
|
||
|
||
Dim viewObj As Object
|
||
Set viewObj = BuildViewFromSheet()
|
||
If Not viewObj Is Nothing Then
|
||
apiBody.Add "View", viewObj
|
||
End If
|
||
|
||
Dim res As Object
|
||
Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody)
|
||
|
||
If res("StatusCode") = 200 Then
|
||
Debug.Print "レコードの取得に成功しました"
|
||
Set getRecordsData = res("Response")("Data")
|
||
End If
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'レコードDictionary内のネストした*Hash（ClassHash、NumHash、DateHash、DescriptionHash、CheckHashなど）を
|
||
'展開し、1階層のDictionaryにフラット化する
|
||
Function FlattenRecord(record As Dictionary) As Dictionary
|
||
Dim flat As New Dictionary
|
||
Dim key As Variant
|
||
For Each key In record.Keys
|
||
If TypeName(record(key)) = "Dictionary" Then
|
||
Dim innerKey As Variant
|
||
For Each innerKey In record(key).Keys
|
||
flat.Add innerKey, record(key)(innerKey)
|
||
Next innerKey
|
||
Else
|
||
flat.Add key, record(key)
|
||
End If
|
||
Next key
|
||
Set FlattenRecord = flat
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'Get方式で取得したレコードをシートに書き込む（exportCSVDataToSheetとは独立実装）
|
||
'ヘッダはフラット化後の1件目レコードのキー一覧をそのまま使用する（内部キー名のまま、日本語ラベル変換はしない）
|
||
Function getRecordsDataToSheet(records As Collection, targetSheet As String)
|
||
Debug.Print "レコードをシートに出力開始: " & targetSheet
|
||
|
||
Dim ws As Worksheet
|
||
On Error Resume Next
|
||
Set ws = ThisWorkbook.Sheets(targetSheet)
|
||
On Error GoTo 0
|
||
|
||
If ws Is Nothing Then
|
||
Debug.Print "シートが存在しないため新規作成: " & targetSheet
|
||
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))
|
||
ws.Name = targetSheet
|
||
End If
|
||
|
||
If records.count = 0 Then
|
||
Debug.Print "データが0件のため、既存テーブルのデータ部分をクリアします: " & targetSheet
|
||
Dim tblEmpty As ListObject
|
||
On Error Resume Next
|
||
Set tblEmpty = ws.ListObjects(targetSheet)
|
||
On Error GoTo 0
|
||
If Not tblEmpty Is Nothing Then
|
||
If Not tblEmpty.DataBodyRange Is Nothing Then
|
||
tblEmpty.DataBodyRange.ClearContents
|
||
End If
|
||
End If
|
||
Exit Function
|
||
End If
|
||
|
||
Debug.Print " [DEBUG] records.count = " & records.count
|
||
|
||
Dim flatRecords As New Collection
|
||
Dim rec As Dictionary
|
||
For Each rec In records
|
||
flatRecords.Add FlattenRecord(rec)
|
||
Next rec
|
||
|
||
Debug.Print " [DEBUG] flatRecords.count = " & flatRecords.count
|
||
|
||
Dim headerDict As Dictionary
|
||
Set headerDict = flatRecords(1)
|
||
Dim headerKeys As Variant
|
||
headerKeys = headerDict.Keys
|
||
Dim maxCols As Long
|
||
maxCols = headerDict.count
|
||
|
||
Debug.Print " [DEBUG] maxCols = " & maxCols
|
||
|
||
Dim i As Long, j As Long
|
||
Dim dataArr() As Variant
|
||
ReDim dataArr(1 To flatRecords.count, 1 To maxCols)
|
||
For i = 1 To flatRecords.count
|
||
Dim curRec As Dictionary
|
||
Set curRec = flatRecords(i)
|
||
For j = 1 To maxCols
|
||
dataArr(i, j) = NormalizeGetValue(curRec(headerKeys(j - 1)))
|
||
Next j
|
||
Next i
|
||
|
||
Debug.Print " [DEBUG] dataArr dims = " & UBound(dataArr, 1) & " x " & UBound(dataArr, 2)
|
||
Debug.Print " [DEBUG] dataArr(1,1) = " & CStr(dataArr(1, 1)) & " / dataArr(1,2) = " & CStr(dataArr(1, 2))
|
||
|
||
Dim tbl As ListObject
|
||
On Error Resume Next
|
||
Set tbl = ws.ListObjects(targetSheet)
|
||
On Error GoTo 0
|
||
|
||
Debug.Print " [DEBUG] tbl Is Nothing (before) = " & (tbl Is Nothing)
|
||
|
||
Dim headerRange As Range
|
||
Set headerRange = ws.Range("A1").Resize(1, maxCols)
|
||
For j = 0 To maxCols - 1
|
||
headerRange.Cells(1, j + 1).Value = headerKeys(j)
|
||
Next j
|
||
|
||
If tbl Is Nothing Then
|
||
Debug.Print "テーブルが存在しないため新規作成: " & targetSheet
|
||
Set tbl = ws.ListObjects.Add(xlSrcRange, headerRange, , xlYes)
|
||
tbl.Name = targetSheet
|
||
End If
|
||
|
||
Debug.Print " [DEBUG] tbl.Range.Address (before resize) = " & tbl.Range.Address
|
||
|
||
If Not tbl.DataBodyRange Is Nothing Then
|
||
tbl.DataBodyRange.ClearContents
|
||
End If
|
||
|
||
'テーブル範囲が直前と同一サイズだとExcelがDataBodyRangeの内部状態を更新しないことがあるため、
|
||
'一旦ヘッダ行のみにリサイズしてから目的のサイズにリサイズし直す
|
||
tbl.Resize tbl.Range.Resize(1, maxCols)
|
||
tbl.Resize tbl.Range.Resize(flatRecords.count + 1, maxCols)
|
||
Debug.Print " [DEBUG] tbl.Range.Address (after resize) = " & tbl.Range.Address
|
||
Debug.Print " [DEBUG] tbl.DataBodyRange Is Nothing (after resize) = " & (tbl.DataBodyRange Is Nothing)
|
||
If Not tbl.DataBodyRange Is Nothing Then
|
||
Debug.Print " [DEBUG] tbl.DataBodyRange.Address = " & tbl.DataBodyRange.Address & " / Rows.count=" & tbl.DataBodyRange.Rows.count & " / Columns.count=" & tbl.DataBodyRange.Columns.count
|
||
End If
|
||
tbl.DataBodyRange.Value = dataArr
|
||
Debug.Print " [DEBUG] after assign, A2 cell value = [" & ws.Range("A2").Value & "]"
|
||
|
||
Debug.Print "レコードのシート出力完了: " & targetSheet
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'Get方式で取得した値のうち、ISO8601形式の日付時刻文字列を正規化する
|
||
'YYYY-MM-DDThh:mm:ss形式 → "yyyy/mm/dd"、未設定を示す1899-12-30は空欄にする
|
||
'オブジェクト値（JSON配列等）は空欄にする
|
||
Function NormalizeGetValue(ByVal v As Variant) As Variant
|
||
If IsObject(v) Then
|
||
NormalizeGetValue = ""
|
||
Exit Function
|
||
End If
|
||
|
||
Dim s As String
|
||
s = CStr(v)
|
||
If Len(s) >= 10 And Mid(s, 5, 1) = "-" And Mid(s, 8, 1) = "-" And Mid(s, 11, 1) = "T" Then
|
||
If Left(s, 10) = "1899-12-30" Then
|
||
NormalizeGetValue = ""
|
||
Else
|
||
NormalizeGetValue = Mid(s, 1, 4) & "/" & Mid(s, 6, 2) & "/" & Mid(s, 9, 2)
|
||
End If
|
||
Else
|
||
NormalizeGetValue = v
|
||
End If
|
||
End Function
|
||
|
||
'******************************************************************************
|
||
'REST API呼出処理
|
||
' method GetかPOSTか
|
||
' url REST APIのURL
|
||
' urlParam リクエストパラメータ（オプション）
|
||
' headers ヘッダ（オプション）
|
||
Function callRestApi(Byval method As String, Byval url As String, Optional Byval urlParam As String = "", Optional Byval headers As Dictionary = Null, Optional Byval body As Dictionary = Null) As Object
|
||
|
||
'HTTPリクエストのオブジェクトを定義
|
||
Dim objHTTP As Object
|
||
Set objHTTP = New XMLHTTP60
|
||
|
||
'HTTPリクエストの接続先を設定
|
||
objHTTP.Open method, url & urlParam, False
|
||
|
||
'リクエストヘッダーを設定（複数ある場合はsetRequestHeaderを複数書けば良いのだ～）
|
||
Dim i As Long
|
||
For i = 0 To headers.count - 1
|
||
objHTTP.setRequestHeader headers.keys(i), headers.items(i)
|
||
Next i
|
||
|
||
'デバッグ用: 送信するリクエストボディを出力（原因調査後に削除する）
|
||
Debug.Print " [DEBUG] Request Body: " & JsonConverter.ConvertToJson(body)
|
||
|
||
'リクエスト送信
|
||
objHTTP.send JsonConverter.ConvertToJson(body)
|
||
|
||
Do While objHTTP.readyState < 4
|
||
DoEvents
|
||
Loop
|
||
|
||
'デバッグ用: レスポンス全文を出力（原因調査後に削除する）
|
||
Debug.Print " [DEBUG] Response Status: " & objHTTP.Status & " " & objHTTP.statusText
|
||
Debug.Print " [DEBUG] Response Body (全文):"
|
||
Debug.Print objHTTP.responseText
|
||
|
||
'レスポンスの文字列（objHTTP.responseText）をJsonに変換して返却
|
||
Set callRestApi = JsonConverter.ParseJson(objHTTP.responseText)
|
||
|
||
End Function
|
||
|
||
|
||
'******************************************************************************
|
||
'基本情報シートにFilter表(F2:G2)・Sorter表(H2:I2)のテーブルをセットアップする
|
||
'新版着工要因閲覧シートv0.1.xlsm上で手動実行する想定（run()からは呼ばない）
|
||
'既にテーブルが存在する場合は何もしない
|
||
Sub SetupFilterSorterTables()
|
||
Dim ws As Worksheet
|
||
Set ws = ThisWorkbook.Sheets("基本情報")
|
||
|
||
Dim filterTbl As ListObject
|
||
On Error Resume Next
|
||
Set filterTbl = ws.ListObjects("FilterTable")
|
||
On Error GoTo 0
|
||
|
||
If filterTbl Is Nothing Then
|
||
Dim filterHeader As Range
|
||
Set filterHeader = ws.Range("F2:G2")
|
||
filterHeader.Cells(1, 1).Value = "列名"
|
||
filterHeader.Cells(1, 2).Value = "値"
|
||
Set filterTbl = ws.ListObjects.Add(xlSrcRange, filterHeader, , xlYes)
|
||
filterTbl.Name = "FilterTable"
|
||
End If
|
||
|
||
Dim sorterTbl As ListObject
|
||
On Error Resume Next
|
||
Set sorterTbl = ws.ListObjects("SorterTable")
|
||
On Error GoTo 0
|
||
|
||
If sorterTbl Is Nothing Then
|
||
Dim sorterHeader As Range
|
||
Set sorterHeader = ws.Range("J2:K2")
|
||
sorterHeader.Cells(1, 1).Value = "列名"
|
||
sorterHeader.Cells(1, 2).Value = "昇降順"
|
||
Set sorterTbl = ws.ListObjects.Add(xlSrcRange, sorterHeader, , xlYes)
|
||
sorterTbl.Name = "SorterTable"
|
||
End If
|
||
End Sub
|
||
|
||
'******************************************************************************
|
||
'ブック内の全シートからテーブル名でテーブル（ListObject）を探し、CSVデータ（ヘッダ行を除く）を上書きする。
|
||
'シート名は問わない。テーブルが見つからない場合は新規作成せずメッセージを出して終了する
|
||
Function exportCSVDataToExistingTable(csvData As Variant, tableName As String)
|
||
Debug.Print "CSVデータを既存テーブルに出力開始: " & tableName
|
||
|
||
Dim tbl As ListObject
|
||
Set tbl = FindListObjectByName(tableName)
|
||
|
||
If tbl Is Nothing Then
|
||
MsgBox "テーブルが存在しません: " & tableName, vbExclamation
|
||
Exit Function
|
||
End If
|
||
|
||
Dim i As Long, j As Long
|
||
Dim arr() As Variant
|
||
Dim maxCols As Long
|
||
|
||
Dim rows As Collection
|
||
Set rows = ParseCsv(csvData)
|
||
|
||
If rows.count <= 1 Then
|
||
MsgBox "データが存在しません（ヘッダのみ）: " & tableName, vbExclamation
|
||
Exit Function
|
||
End If
|
||
|
||
maxCols = 0
|
||
Dim rowArr As Variant
|
||
For Each rowArr In rows
|
||
If UBound(rowArr) + 1 > maxCols Then
|
||
maxCols = UBound(rowArr) + 1
|
||
End If
|
||
Next rowArr
|
||
|
||
ReDim arr(0 To rows.count - 1, 0 To maxCols - 1)
|
||
|
||
i = 0
|
||
For Each rowArr In rows
|
||
For j = LBound(rowArr) To UBound(rowArr)
|
||
arr(i, j) = rowArr(j)
|
||
Next j
|
||
i = i + 1
|
||
Next rowArr
|
||
|
||
If Not tbl.DataBodyRange Is Nothing Then
|
||
tbl.DataBodyRange.ClearContents
|
||
End If
|
||
|
||
'直前と同一サイズへのResizeだとExcelがDataBodyRangeの内部状態を更新しないことがあるため、
|
||
'一旦ヘッダ行のみにリサイズしてから目的のサイズにリサイズし直す
|
||
tbl.Resize tbl.Range.Resize(1, maxCols)
|
||
tbl.Resize tbl.Range.Resize(rows.count, maxCols)
|
||
|
||
Dim dataArr() As Variant
|
||
ReDim dataArr(1 To rows.count - 1, 1 To maxCols)
|
||
For i = 1 To rows.count - 1
|
||
For j = 1 To maxCols
|
||
dataArr(i, j) = arr(i, j - 1)
|
||
Next j
|
||
Next i
|
||
tbl.DataBodyRange.Value = dataArr
|
||
|
||
Debug.Print "CSVデータを既存テーブルに出力完了: " & tableName
|
||
End Function
|
||
|
||
'テーブルID 96243（営業所マスタ）をExport方式で全件取得し、「営業所」シートの既存テーブルを更新する
|
||
'ソートはNumA昇順で固定。Filterは使用しない。ヘッダ行は既存テーブルのものをそのまま使い、
|
||
'エクスポートしたCSVのヘッダ行（1行目）は捨てる。新規シート・テーブルの作成は行わない
|
||
Sub runSalesOfficeExport()
|
||
Call init
|
||
|
||
Dim resData As Variant
|
||
|
||
'ソート条件（NumA昇順）を固定で組み立てる
|
||
Dim colSorter As New Dictionary
|
||
colSorter.Add "NumA", "asc"
|
||
Dim viewObj As New Dictionary
|
||
viewObj.Add "ColumnSorterHash", colSorter
|
||
|
||
Debug.Print "データ取得処理開始（営業所マスタ Export）"
|
||
resData = exportCSVData("96243", viewObj)
|
||
|
||
If IsEmpty(resData) Or resData = "" Then
|
||
Debug.Print "データが取得できませんでした"
|
||
Else
|
||
Call exportCSVDataToExistingTable(resData, "営業所")
|
||
End If
|
||
End Sub |