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

fix: Export/Get方式とも0件取得時にテーブルのデータ部分をクリアするよう修正

Browse Source 
従来は0件時にMsgBoxを出して即終了し、テーブルの前回データがそのまま残ってしまっていた。
runGetFlowはrecords.count=0でもgetRecordsDataToSheetを呼ぶよう変更し、getRecordsDataToSheet/exportCSVDataToSheetは0件時にMsgBoxを出さずヘッダを維持したままDataBodyRangeだけクリアするよう修正。

Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com>
This commit is contained in:
Kenichiro NOGI 2026-09-18 18:44:42 +09:00
parent 06340cdb7b
commit 67b9f8c0f8
1 changed files with 25 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -106,9 +106,6 @@ Function runGetFlow() As Boolean
If records Is Nothing Then If records Is Nothing Then
Debug.Print "データが取得できませんでした" Debug.Print "データが取得できませんでした"
runGetFlow = False runGetFlow = False
ElseIf records.count = 0 Then
Debug.Print "データが取得できませんでした"
runGetFlow = False
Else Else
Call getRecordsDataToSheet(records, tableId & "G") Call getRecordsDataToSheet(records, tableId & "G")
t2 = Timer t2 = Timer
@ -180,7 +177,16 @@ Function exportCSVDataToSheet(csvData As Variant, targetSheet As String)
Set rows = ParseCsv(csvData) Set rows = ParseCsv(csvData)
If rows.count <= 1 Then If rows.count <= 1 Then
MsgBox "データが存在しません（ヘッダのみ）: " & targetSheet, vbExclamation 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 Exit Function
End If End If
@ -448,11 +454,6 @@ End Function
Function getRecordsDataToSheet(records As Collection, targetSheet As String) Function getRecordsDataToSheet(records As Collection, targetSheet As String)
Debug.Print "レコードをシートに出力開始: " & targetSheet Debug.Print "レコードをシートに出力開始: " & targetSheet
If records.count = 0 Then
MsgBox "データが存在しません: " & targetSheet, vbExclamation
Exit Function
End If
Dim ws As Worksheet Dim ws As Worksheet
On Error Resume Next On Error Resume Next
Set ws = ThisWorkbook.Sheets(targetSheet) Set ws = ThisWorkbook.Sheets(targetSheet)
@ -464,6 +465,20 @@ Function getRecordsDataToSheet(records As Collection, targetSheet As String)
ws.Name = targetSheet ws.Name = targetSheet
End If 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
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