access vba グループごとにCSVファイルを作成で「実行時エラー3021 カレントレコードがありません」

Question

実現したいこと

タイトルのエラーを回避したい。

発生している問題・分からないこと

ファイル生成は成功するのですが，なんかうまく終了しないので戦いましたが（もう何十時間もかかって
疲弊）ほんとに分からないです。（泣きたいです）

groupField　がなくなったら，という処理がないような気がします。
なのでgroupFieldの空の行を掴んでエラーしている印象なのです。

現在は　On Error GoTo myError　で無理やり終了させてます..............

エラーメッセージ

実行時エラー3021　カレントレコードがありません

該当のソースコード

Sub ExportGroupToCSV()
    Dim rs As DAO.Recordset
    Dim groupField As String
    Dim outputPath As String
    Dim sql As String
    Dim qdf As QueryDef
    
    ' グループ化するフィールド名
    groupField = "GroupName"
    
    ' 出力先のフォルダパス
    outputPath = "C:\Output\"  ' 出力先のフォルダを適切なパスに変更してください
    
    ' クエリのSQL文を構築
    sql = "SELECT * FROM YourTable ORDER BY " & groupField
    
    ' クエリを作成
    Set qdf = CurrentDb.CreateQueryDef("", sql)
    
    ' レコードセットを取得
    Set rs = qdf.OpenRecordset
    
    ' レコードセットをグループ単位で処理
    Do While Not rs.EOF
        ' グループごとにファイルを作成してデータを書き込む
        Dim groupValue As String
        groupValue = rs.Fields(groupField).Value
        
        ' CSVファイルに書き込む
        Open outputPath & groupValue & ".csv" For Output As #1
        Print #1, "Header1, Header2, Header3"  ' ヘッダー行を書き込む（適切なヘッダー名に変更してください）->不要
        
        ' グループごとのデータを書き込む
        Do While Not rs.EOF And rs.Fields(groupField).Value = groupValue
            Print #1, rs.Fields("Field1").Value & ", " & rs.Fields("Field2").Value & ", " & rs.Fields("Field3").Value  ' データ行を書き込む（フィールド名を適切なものに変更してください）
            rs.MoveNext
        Loop
        
        ' ファイルを閉じる
        Close #1
    Loop
    
    ' レコードセットとクエリを解放
    rs.Close
    Set rs = Nothing
    Set qdf = Nothing
End Sub

試したこと・調べたこと

• teratailやGoogle等で検索した
• ソースコードを自分なりに変更した
• 知人に聞いた
• その他

上記の詳細・結果

グループごとにいったんテーブルに入れてcsv出力したりしましたが，
あとちょっとなのでこのソースがスルッと終われるならこれを使いたいです。

補足

特になし

Comments

[sk.exe]

> ' グループ化するフィールド名
> groupField = "GroupName"

フィールド[GroupName]のデータ型を明記されることをお奨めします。

[emplus]

ですよね，フィールド[GroupName]のデータ型がわかってません....
文字列だとは思いますが，コピペなもので....
すみません...

[sk.exe]

> フィールド[GroupName]のデータ型がわかってません

Access 上でテーブル[YourTable]をデザインビューで開いて確認なされば判るかと思います。

> ' グループごとにファイルを作成してデータを書き込む
> Dim groupValue As String
> groupValue = rs.Fields(groupField).Value

少なくとも、もしフィールド[GroupName]の値が Null であるレコードがテーブル[YourTable]に1件以上存在した場合、そのレコードの[GroupName]の値（ Null ）を String 型の変数 groupValue に代入しようとすれば、実行時エラー 94 が発生することになるでしょう。

[emplus]

ありがとうございます。

短いテキスト型，つまりはStrings型です。

なるほど，代入しようとしたって型が違いますよ，ということですね。

[emplus]

Do While Not rs.EOF And rs.Fields(groupField).Value = groupValue　を
Do While Not rs.EOF 'And rs.Fields(groupField).Value = groupValue　にしたら
ファイル化はされました！
でもグループごとでなくなりました..........................................
chat gpt君がソース吐き出したときは感激したんですが...

Answer 1

        ' グループごとのデータを書き込む
        Do While Not rs.EOF And rs.Fields(groupField).Value = groupValue
            Print #1, rs.Fields("Field1").Value & ", " & rs.Fields("Field2").Value & ", " & rs.Fields("Field3").Value  ' データ行を書き込む（フィールド名を適切なものに変更してください）
            rs.MoveNext
        Loop        

「Not rs.EOF And rs.Fields(groupField).Value = groupValue」この部分ですが
VBAでは、rs.EOFがTrueの時も「rs.Fields(groupField).Value = groupValue」がチェックされます。

rs.EOFがTrueの時は、もうレコードの終わりに来ているのでrs.Fields(groupField)にアクセスしようとして
3021番のエラーが出ます。

エラーの原因は、この通りです。
修正するには以下のようにする必要があります。

        Do While Not rs.EOF
            If Not rs.Fields(groupField).Value = groupValue Then
                Exit Do
            End If
            Print #1, rs.Fields("Field1").Value & ", " & rs.Fields("Field2").Value & ", " & rs.Fields("Field3").Value  ' データ行を書き込む（フィールド名を適切なものに変更してください）
            rs.MoveNext
        Loop

まぁ。GroupName　にNullがあったら、別の理由でエラーになりますが
今回の件は、これで解決するのではないかと思われます。

Comments

[emplus]

＞rs.EOFがTrueの時は、もうレコードの終わりに来ているのでrs.Fields(groupField)にアクセスしようと

うぁ，なるほどそういうことだったのですか!

ご指摘通り修正したら見事に動きました。

55歳には難しすぎました

有難うございます。

Answer 2

フィールド[GroupName]のデータ型

短いテキスト型

Sub ExportGroupToCSV()
    
    Dim outputPath As String
    
    '出力先フォルダパスの設定
    outputPath = "C:\Output"
    
    'フォルダパスの実在チェック
    If Dir(outputPath, vbDirectory) = "" Then
        '見つからなければ終了
        MsgBox "フォルダ""" & outputPath & """が見つかりません。", _
               vbExclamation, _
               "フォルダ参照エラー"
        Exit Sub
    End If
    
    '末尾にパス区切り文字を追記
    outputPath = outputPath & "\"
    
    Dim db As DAO.Database
    
    'カレントデータベースの参照
    Set db = CurrentDb
    
    Dim rsGroup As DAO.Recordset
    Dim groupField As String
    Dim sql As String
    
    'グループ化するフィールドの名前を設定
    groupField = "GroupName"
    
    '変数 groupField と同じ名前のフィールドをグループ化した結果
    '（以下「グループセット」）を得る。
    'フィールドの値が Null である場合は空文字列として扱う。
    sql = "SELECT Nz(t1.[" & groupField & "],'') AS [" & groupField & "]" & _
          " FROM [YourTable] t1" & _
          " GROUP BY Nz(t1.[" & groupField & "],'')"
    Set rsGroup = db.OpenRecordset(sql, dbOpenSnapshot)
    
    'レコードが1件も存在しない場合は終了
    If rsGroup.EOF Then
        rsGroup.Close
        Set rsGroup = Nothing
        Set db = Nothing
        Exit Sub
    End If
    
    Dim qdf As DAO.QueryDef
    
    ' 一時的なパラメータクエリの作成
    sql = "PARAMETERS [ItemKey] TEXT(255);" & _
          "SELECT t1.[Field1] AS [Header1], t1.[Field2] AS [Header2], t1.[Field3] AS [Header3]" & _
          " FROM [YourTable] t1" & _
          " WHERE Nz(t1.[" & groupField & "],'')=Nz([ItemKey],'')"
    Set qdf = db.CreateQueryDef("", sql)
    
    Dim rsDetail As DAO.Recordset
    Dim fld As DAO.Field
    Dim groupValue As String
    Dim fileName As String
    Dim headerRow As String
    Dim dataRow As String
    
    'グループセットの全てのレコードを読み切るまでループ
    Do Until rsGroup.EOF
        
        '現在のグループの値を取得する
        groupValue = rsGroup.Fields(groupField).Value
        
        'パラメータクエリを実行し、現在のグループに該当するレコードを抽出した結果
        '（以下「詳細セット」）を得る
        With qdf
            'クエリパラメータへの値渡し
            .Parameters("ItemKey").Value = groupValue
            'クエリを実行した結果をレコードセットとして取得する
            Set rsDetail = .OpenRecordset(dbOpenSnapshot)
        End With
        
        '詳細セットの各フィールドの名前から、列見出し行として出力する文字列を生成する。
        'この処理は1度だけ実行する。
        If headerRow = "" Then
            For Each fld In rsDetail.Fields
                headerRow = headerRow & _
                            "," & fld.Name
            Next
            headerRow = Mid(headerRow, 2)
        End If
           
        '現在のグループの値が空文字列である場合
        If groupValue = "" Then
            '他のグループと競合しない文字列をファイル名として設定
            fileName = "グループが不明であるレコード"
        '現在のグループの値が空文字列ではない場合
        Else
            '現在のグループの値をそのままファイル名とする
            '（厳密には、ファイルパスとして使用できない文字が含まれる可能性があるなら
            'エスケープ処理を加えた方がよいが、このサンプルでは割愛する）
            fileName = groupValue
        End If
        'ファイル拡張子を追記
        fileName = fileName & ".csv"
                
        'ファイル出力の開始
        Open outputPath & fileName For Output As #1
        
        '列見出し行の書き込み
        Print #1, headerRow
        
        '詳細セットの全てのレコードを読み切るまでループ
        Do Until rsDetail.EOF
        
            '詳細セットの各フィールドの値から、データ行として出力する文字列を生成する
            dataRow = ""
            For Each fld In rsDetail.Fields
                dataRow = dataRow & _
                          "," & Nz(fld.Value, "")
            Next
            dataRow = Mid(dataRow, 2)
            
            'データ行の書き込み
            Print #1, dataRow
            
            '詳細セットのカレントレコードを次のレコードに移動
            rsDetail.MoveNext
        Loop
        
        '詳細セットを閉じる
        rsDetail.Close
        Set rsDetail = Nothing
        
        'ファイルを閉じる
        Close #1
        
        'グループセットのカレントレコードを次のレコードに移動
        rsGroup.MoveNext
    Loop
    
    'グループセットを閉じる
    rsGroup.Close
    Set rsGroup = Nothing
    
    Set qdf = Nothing
    Set db = Nothing

End Sub

Comments

[emplus]

え！え！なんすかこの美しいソース，，，，

[emplus]

こちらも見事に動きました。
ソースの内容が秀逸で今後大事に利用させてもらいます。
特に詳細セットという考え方がMagicでした。

わざわざ記述頂きありがとうございました。

Answer 3

このエラーは、ループがレコードセットの最後に達した後に、次のレコードを取得しようとして発生します。これは、内側のループで rs.MoveNext を呼び出す前に、EOF (End of File) をチェックすることで解決できると思います。

Sub ExportGroupToCSV()
    Dim rs As DAO.Recordset
    Dim groupField As String
    Dim outputPath As String
    Dim sql As String
    Dim qdf As QueryDef
    
    ' グループ化するフィールド名
    groupField = "GroupName"
    
    ' 出力先のフォルダパス
    outputPath = "C:\Output\"  ' 出力先のフォルダを適切なパスに変更してください
    
    ' クエリのSQL文を構築
    sql = "SELECT * FROM YourTable ORDER BY " & groupField
    
    ' クエリを作成
    Set qdf = CurrentDb.CreateQueryDef("", sql)
    
    ' レコードセットを取得
    Set rs = qdf.OpenRecordset
    
    ' レコードセットをグループ単位で処理
    Do While Not rs.EOF
        ' グループごとにファイルを作成してデータを書き込む
        Dim groupValue As String
        groupValue = rs.Fields(groupField).Value
        
        ' CSVファイルに書き込む
        Open outputPath & groupValue & ".csv" For Output As #1
        Print #1, "Header1, Header2, Header3"  ' ヘッダー行を書き込む（適切なヘッダー名に変更してください）->不要
        
        ' グループごとのデータを書き込む
        Do While Not rs.EOF And rs.Fields(groupField).Value = groupValue
            Print #1, rs.Fields("Field1").Value & ", " & rs.Fields("Field2").Value & ", " & rs.Fields("Field3").Value  ' データ行を書き込む（フィールド名を適切なものに変更してください）
            rs.MoveNext
        Loop
        
        ' ファイルを閉じる
        Close #1
    Loop
    
    ' レコードセットとクエリを解放
    rs.Close
    Set rs = Nothing
    Set qdf = Nothing
End Sub

これにより、ループが最後のレコードに達した後でも、追加の MoveNext の呼び出しは行われなくなり、エラーが解消されるはずです。一度、トライをお願いします

Comments

[emplus]

そうなんですね！でも書き込む場所がわからなくて....
Do While Not rs.EOF And rs.Fields(groupField).Value = groupValue　を
「改行キーはきにしないで，groupFieldがあるかぎり，Printせよ　って思っていて...（たぶん違う）
ご指摘のお話しですと　rs.MoveNext　の前あたりに　IIf rs.EOF = True Then Exit Do　などと書いて
見事にエラー。というレベルで本当に申し訳ないです。

[emplus]

chatgpt-Monica様にきいたところ，
Do While Not rs.EOF
If rs.Fields(groupField).Value = groupValue Then
　　　Print #1　～省略ご了承～
　　　End If
　　　rs.MoveNext
　Loop
だというので実行してみたらエラーは消えましたが，ファイルが先頭のグループだけで終わってしまいました。

111,りんご,赤い
222,みかん,黄色い

といったデータなのですが，
111.csvでスルッと終わるという...........