fix: テーブルResize時にDataBodyRangeがNothingのままになる問題を修正

Excelのテーブル(ListObject)は、直前と同一サイズへのResizeを行うとDataBodyRangeの内部状態が更新されないことがあり、
データ行数が変わらない場合(前回0件クリア後に1件だけ取得した場合など)にDataBodyRange.Value代入が効かず、
テーブルにデータが書き込まれない不具合があった。
exportCSVDataToSheet/getRecordsDataToSheet/exportCSVDataToExistingTableの3箇所で、
一旦ヘッダ行のみにリサイズしてから目的のサイズにリサイズし直すことで回避。
調査用の詳細デバッグログ([DEBUG] records.count等)も合わせて追加。

Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com>
This commit is contained in:
Kenichiro NOGI 2026-09-18 18:56:37 +09:00
parent 67b9f8c0f8
commit a60244b7b0

View File

@ -235,6 +235,9 @@ Function exportCSVDataToSheet(csvData As Variant, targetSheet As String)
End If End If
' テーブルにデータを追加(ヘッダ行(arr(0,*))を除いたデータ部分のみをDataBodyRangeに書き込む ' テーブルにデータを追加(ヘッダ行(arr(0,*))を除いたデータ部分のみをDataBodyRangeに書き込む
'直前と同一サイズへのResizeだとExcelがDataBodyRangeの内部状態を更新しないことがあるため、
'一旦ヘッダ行のみにリサイズしてから目的のサイズにリサイズし直す
tbl.Resize tbl.Range.Resize(1, maxCols)
tbl.Resize tbl.Range.Resize(rows.count, maxCols) tbl.Resize tbl.Range.Resize(rows.count, maxCols)
Dim dataArr() As Variant Dim dataArr() As Variant
@ -479,12 +482,16 @@ Function getRecordsDataToSheet(records As Collection, targetSheet As String)
Exit Function Exit Function
End If End If
Debug.Print " [DEBUG] records.count = " & records.count
Dim flatRecords As New Collection Dim flatRecords As New Collection
Dim rec As Dictionary Dim rec As Dictionary
For Each rec In records For Each rec In records
flatRecords.Add FlattenRecord(rec) flatRecords.Add FlattenRecord(rec)
Next rec Next rec
Debug.Print " [DEBUG] flatRecords.count = " & flatRecords.count
Dim headerDict As Dictionary Dim headerDict As Dictionary
Set headerDict = flatRecords(1) Set headerDict = flatRecords(1)
Dim headerKeys As Variant Dim headerKeys As Variant
@ -492,6 +499,8 @@ Function getRecordsDataToSheet(records As Collection, targetSheet As String)
Dim maxCols As Long Dim maxCols As Long
maxCols = headerDict.count maxCols = headerDict.count
Debug.Print " [DEBUG] maxCols = " & maxCols
Dim i As Long, j As Long Dim i As Long, j As Long
Dim dataArr() As Variant Dim dataArr() As Variant
ReDim dataArr(1 To flatRecords.count, 1 To maxCols) ReDim dataArr(1 To flatRecords.count, 1 To maxCols)
@ -503,11 +512,16 @@ Function getRecordsDataToSheet(records As Collection, targetSheet As String)
Next j Next j
Next i 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 Dim tbl As ListObject
On Error Resume Next On Error Resume Next
Set tbl = ws.ListObjects(targetSheet) Set tbl = ws.ListObjects(targetSheet)
On Error GoTo 0 On Error GoTo 0
Debug.Print " [DEBUG] tbl Is Nothing (before) = " & (tbl Is Nothing)
Dim headerRange As Range Dim headerRange As Range
Set headerRange = ws.Range("A1").Resize(1, maxCols) Set headerRange = ws.Range("A1").Resize(1, maxCols)
For j = 0 To maxCols - 1 For j = 0 To maxCols - 1
@ -520,12 +534,23 @@ Function getRecordsDataToSheet(records As Collection, targetSheet As String)
tbl.Name = targetSheet tbl.Name = targetSheet
End If End If
Debug.Print " [DEBUG] tbl.Range.Address (before resize) = " & tbl.Range.Address
If Not tbl.DataBodyRange Is Nothing Then If Not tbl.DataBodyRange Is Nothing Then
tbl.DataBodyRange.ClearContents tbl.DataBodyRange.ClearContents
End If End If
'テーブル範囲が直前と同一サイズだとExcelがDataBodyRangeの内部状態を更新しないことがあるため、
'一旦ヘッダ行のみにリサイズしてから目的のサイズにリサイズし直す
tbl.Resize tbl.Range.Resize(1, maxCols)
tbl.Resize tbl.Range.Resize(flatRecords.count + 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 tbl.DataBodyRange.Value = dataArr
Debug.Print " [DEBUG] after assign, A2 cell value = [" & ws.Range("A2").Value & "]"
Debug.Print "レコードのシート出力完了: " & targetSheet Debug.Print "レコードのシート出力完了: " & targetSheet
End Function End Function
@ -680,6 +705,9 @@ Function exportCSVDataToExistingTable(csvData As Variant, tableName As String)
tbl.DataBodyRange.ClearContents tbl.DataBodyRange.ClearContents
End If End If
'直前と同一サイズへのResizeだとExcelがDataBodyRangeの内部状態を更新しないことがあるため、
'一旦ヘッダ行のみにリサイズしてから目的のサイズにリサイズし直す
tbl.Resize tbl.Range.Resize(1, maxCols)
tbl.Resize tbl.Range.Resize(rows.count, maxCols) tbl.Resize tbl.Range.Resize(rows.count, maxCols)
Dim dataArr() As Variant Dim dataArr() As Variant