mygit-admin/ken_nogi
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
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
1 changed files with 28 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
XVBA/新版着工要因閲覧シート/vba-files/Module/Module1.bas
View File

@ -235,6 +235,9 @@ Function exportCSVDataToSheet(csvData As Variant, targetSheet As String)
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
@ -479,12 +482,16 @@ Function getRecordsDataToSheet(records As Collection, targetSheet As String)
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
@ -492,6 +499,8 @@ Function getRecordsDataToSheet(records As Collection, targetSheet As String)
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)
@ -503,11 +512,16 @@ Function getRecordsDataToSheet(records As Collection, targetSheet As String)
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
@ -520,12 +534,23 @@ Function getRecordsDataToSheet(records As Collection, targetSheet As String)
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
@ -680,6 +705,9 @@ Function exportCSVDataToExistingTable(csvData As Variant, tableName As String)
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