Access (VBA)

Access VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Access 2016)
エクスポートの際に100件ごとにファイルを分けたい
投稿日時: 19/09/24 16:07:08
投稿者: hirokiwps

お世話になります。
 
1万レコードある中から100件ごとにcsvファイルにエクスポートしたいのですが
やり方ありますのでしょうか
 
テーブル構成
Aテーブル
名前/住所/電話番号
 
 
知識不足で質問させていただきました。

回答
投稿日時: 19/09/25 11:03:38
投稿者: sk

引用:
1万レコードある中から100件ごとにcsvファイルにエクスポートしたいのですが
やり方ありますのでしょうか

・DoCmd.TransferSpreadsheet メソッドを使う場合
 
・DAO.Recordset オブジェクトを使う場合
 
・ADODB.Stream オブジェクトを使う場合
 
以上のどのケースで対応したいかによるかと。
 
引用:
テーブル構成
Aテーブル
名前/住所/電話番号

・[Aテーブル]の主キーはどのフィールドか。
 また、ファイル出力に際してレコードの並べ替え順について
 特に指定はないのか。
 
・CSV ファイルの先頭行を列見出しにする必要があるのか否か。
 
・テキスト型の列の各値をダブルクォーテーションで囲む
 必要があるのか否か。
 
・CSV ファイルの文字セットについて特に指定はないのか。

投稿日時: 19/09/25 11:39:00
投稿者: hirokiwps

sk様
ご回答ありがとうございます。
 
 
テーブル構成
Aテーブル
注文番号/名前/住所/電話番号
 
・[Aテーブル]の主キーはどのフィールドか。
  また、ファイル出力に際してレコードの並べ替え順について
 特に指定はないのか。
 →注文番号が抜けておりましたので追記いたしました。
  注文番号順にて昇順にて並べ替えが必要となります。
 
・CSV ファイルの先頭行を列見出しにする必要があるのか否か。
 →列見出しは必要となります。
・テキスト型の列の各値をダブルクォーテーションで囲む
 必要があるのか否か。
 →必要となります。
・CSV ファイルの文字セットについて特に指定はないのか。
→特に必要はありません。
 
初心者なもので説明不足がありましたら申し訳ございませんがよろしくお願いいたします。

回答
投稿日時: 19/09/25 14:20:04
投稿者: sk

引用:
注文番号順にて昇順にて並べ替えが必要となります。

引用:
列見出しは必要となります。

引用:
テキスト型の列の各値をダブルクォーテーションで囲む

引用:
文字セットについて特に指定はない

ではとりあえず、以下の手法を用いた場合のサンプルを例示します。
( Microsoft ActiveX Data Objects Library 6.1 への参照が必要)
 
引用:
・ADODB.Stream オブジェクトを使う場合

(標準モジュール)
-------------------------------------------------------------
Sub ExportCsvByAdoStream()
     
    Const ColumnDelimiter As String = ","
    Const HasHeader As Boolean = True
    Const MaxRecordsInFile As Long = 100
     
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim fld As ADODB.Field
    Dim strm As ADODB.Stream
     
    Dim lngCount As Long
    Dim lngFiles As Long
    Dim lngCountInFile As Long
     
    Dim strHeader As String
    Dim strRow As String
    Dim strRecords As String
     
    Dim strFolderPath As String
    Dim strFilePath As String
 
    Set cn = CurrentProject.Connection
     
    Set rs = New ADODB.Recordset
     
    With rs
        Set .ActiveConnection = cn
        .Source = "SELECT * FROM [Aテーブル] ORDER BY [注文番号];"
        .CursorLocation = adUseClient
        .CursorType = adOpenKeyset
        .LockType = adLockReadOnly
        .Open
         
        If .EOF Then
            .Close
            Set rs = Nothing
            cn.Close
            Set cn = Nothing
            MsgBox "出力対象となるレコードがありません。", _
                   vbInformation, _
                   "レコードなし"
            Exit Sub
        End If
         
        If HasHeader Then
            For Each fld In .Fields
                strHeader = strHeader & ColumnDelimiter & """" & fld.Name & """"
            Next
            strHeader = Mid(strHeader, Len(ColumnDelimiter) + 1) & vbCrLf
        End If
         
        strFolderPath = CurrentProject.Path & "\csv_" & Format(Now(), "yyyymmddhhnnss")
         
        If Dir(strFolderPath, vbDirectory) = "" Then
            MkDir strFolderPath
        End If
         
        strRecords = ""
        lngCount = 0
        lngCountInFile = 0
        lngFiles = 0
         
        Do Until .EOF
            lngCount = lngCount + 1
            lngCountInFile = lngCountInFile + 1
             
            strRow = ""
            For Each fld In .Fields
                Select Case fld.Type
                    Case adVarWChar, adWChar, adVarChar, adChar, _
                         adLongVarWChar, adLongVarChar, adBSTR
                        strRow = strRow & ColumnDelimiter & _
                                 """" & Replace(Nz(fld.Value, ""), """", """""", , , vbBinaryCompare) & """"
                    Case adDate
                        strRow = strRow & ColumnDelimiter & _
                                 Format(fld.Value, "yyyy/mm/dd hh:nn:ss")
                    Case Else
                        strRow = strRow & ColumnDelimiter & _
                                 fld.Value
                End Select
            Next
            strRow = Mid(strRow, Len(ColumnDelimiter) + 1) & vbCrLf
             
            strRecords = strRecords & _
                         strRow
             
            If (MaxRecordsInFile > 0 And lngCountInFile = MaxRecordsInFile) Or _
               (lngCount = .RecordCount) Then
                 
                lngFiles = lngFiles + 1
                strFilePath = strFolderPath & "\File" & Format(lngFiles, "000000") & ".csv"
                 
                Set strm = New ADODB.Stream
                With strm
                    .Type = adTypeText
                    .Charset = "UTF-8"
                    .Open
                    If HasHeader Then
                        .WriteText strHeader, adWriteChar
                    End If
                    .WriteText strRecords, adWriteChar
                    .SaveToFile strFilePath, adSaveCreateNotExist
                    Debug.Print strFilePath
                    .Close
                End With
                Set strm = Nothing
             
                strRecords = ""
                lngCountInFile = 0
            End If
             
            .MoveNext
        Loop
     
    End With
     
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
     
    Application.FollowHyperlink strFolderPath
     
End Sub
-------------------------------------------------------------

投稿日時: 19/09/30 08:19:29
投稿者: hirokiwps

sk様
ご回答ありがとうございます。
お時間が空いてしまってすいません。
 
無事にできましたのでありがとうございました。