以前に、非連結のテキストボックスやコンボボックスから抽出したレコードをフォームのレコードソースにする方法を記事にしたことがありました。
https://pctips.jp/pc-soft/access-textbox-judg-extract/
今回は、
ココがポイント
その抽出したレコードソースを、CSVファイルなどにエクスポートする方法
をやって見たいと思います。
方法は一つじゃない！？
方法はいくつかあるのかと思いながらもネットで同じような事例が無いかと調べましたが、中々出てきません。
いちばん簡単なのは、非連結ボックスや非連結のコンボボックスを指定して抽出したクエリをそのままエクスポートすれば事は足りると思います。
https://pctips.jp/pc-soft/access-export-selectfolder/
ただ、今回は、せっかくフォームのレコードソースとしてVBAにて抽出したので、そのレコードソースをエクスポートできないものか？と考えた訳です。
ダミーのクエリを使ってエクスポート
ネットを探してみると、なんでダミーのクエリをつかってエクスポートできるのかわかりませんが、下記の様なコードを見つけました。
Dim qd As DAO.QueryDef
Set qd = CurrentDb.QueryDefs("Q_Dummy")
qd.SQL = "SELECT * FROM (フォームのレコードソース) WHERE " & Me.Filter
DoCmd.TransferText acExportDelim, , "Q_Dummy", "C:\Test\Test.csv", True
ほぼ諦めかけていたので、DAOを嫌っていた自分ですが、今回はDAOを使ってほしい機能が実現できたので良しとしました。
複雑なＳＱＬ抽出データをエクスポート
Private Sub csv_xport_Click()
Dim hantei As Integer
Dim naiyou As String
Dim dbs As DAO.Database
Dim qdf As DAO.QueryDef
Dim flg As Boolean
Dim strSql As String
Dim strPath As String
Dim FolderName As String
FolderName = getFolderName("") '引数に初期値のフォルダーパスを設定、""にするとドキュメントフォルダー
If FolderName = "" Then
MsgBox "キャンセルされました。"
Else
' 条件が設定されてない時は抽出しない
If Nz(Me.search_mado, "") = "" And Nz(Me.delivery_mado, "") = "" And Nz(Me.trader_search, "") = "" And Nz(Me.pu_date_start, "") = "" And Nz(Me.pu_date_end, "") = "" And Nz(Me.delivery_date_start, "") = "" And Nz(Me.delivery_date_end, "") = "" Then
Call 解除ボタン_Click
Exit Sub
End If
haitei = 0
If Nz(Me.pu_date_start, "") <> "" And Nz(Me.pu_date_end, "") <> "" Then
hantei = hantei + 1
ElseIf Nz(Me.pu_date_start, "") <> "" Then
If Nz(Me.pu_date_end, "") = "" Then
MsgBox "集荷日終了が入力されていません"
Exit Sub
End If
ElseIf Nz(Me.pu_date_end, "") <> "" Then
If Nz(Me.pu_date_start, "") = "" Then
MsgBox "集荷日開始が入力されていません"
Exit Sub
End If
End If
If Nz(Me.delivery_date_start, "") <> "" And Nz(Me.delivery_date_end, "") <> "" Then
hantei = hantei + 10
ElseIf Nz(Me.delivery_date_start, "") <> "" Then
If Nz(Me.delivery_date_end, "") = "" Then
MsgBox "配達日終了が入力されていません"
Exit Sub
End If
ElseIf Nz(Me.delivery_date_end, "") <> "" Then
If Nz(Me.delivery_date_start, "") = "" Then
MsgBox "配達日開始が入力されていません"
Exit Sub
End If
End If
If Nz(Me.search_mado, "") <> "" Then ' 出荷人
hantei = hantei + 100
End If
If Nz(Me.trader_search, "") <> "" Then ' 業者
hantei = hantei + 1000
End If
If Nz(Me.delivery_mado, "") <> "" Then ' 配達先
hantei = hantei + 10000
End If
naiyou = "(trader1 ='" & Me!trader_search & "'or trader2 = '" & Me!trader_search & "'or trader3 = '" & Me!trader_search & "'or trader4 = '" & Me!trader_search & "'or trader5 = '" & Me!trader_search & "')"
On Error GoTo Err_Handler
If hantei = 100 Then ' 出荷人
strSql = "SELECT * FROM orderdata_sorting WHERE shipper ='" & Me!search_mado & "'"
ElseIf hantei = 101 Then ' 出荷人+集荷日
strSql = "SELECT * FROM orderdata_sorting WHERE shipper ='" & Me!search_mado & "' And pu_date Between #" & Me!pu_date_start & "# AND #" & Me!pu_date_end & "#"
ElseIf hantei = 111 Then ' 出荷人+集荷日+配達日
strSql = "SELECT * FROM orderdata_sorting WHERE shipper ='" & Me!search_mado & "' And pu_date Between #" & Me!pu_date_start & "# AND #" & Me!pu_date_end & "#" & "And delivery_date Between #" & Me!delivery_date_start & "# AND #" & Me!delivery_date_end & "#"
ElseIf hantei = 10101 Then ' 出荷人+配達先+集荷日
strSql = "SELECT * FROM orderdata_sorting WHERE shipper ='" & Me!search_mado & "'And delivery_name = '" & Me!delivery_mado & "' And pu_date Between #" & Me!pu_date_start & "# AND #" & Me!pu_date_end & "#"
ElseIf hantei = 11 Then ' 集荷日+配達日
strSql = "SELECT * FROM orderdata_sorting WHERE pu_date Between #" & Me!pu_date_start & "# AND #" & Me!pu_date_end & "#" & "And delivery_date Between #" & Me!delivery_date_start & "# AND #" & Me!delivery_date_end & "#"
ElseIf hantei = 1000 Then ' 業者
strSql = "SELECT * FROM orderdata_sorting WHERE " & naiyou
ElseIf hantei = 11000 Then ' 業者+配達先
strSql = "SELECT * FROM orderdata_sorting WHERE delivery_name = '" & Me!delivery_mado & "' and " & naiyou
ElseIf hantei = 11001 Then ' 業者+配達先+集荷日
strSql = "SELECT * FROM orderdata_sorting WHERE delivery_name = '" & Me!delivery_mado & "' and pu_date Between #" & Me!pu_date_start & "# AND #" & Me!pu_date_end & "#" & " and " & naiyou
ElseIf hantei = 1001 Then ' 業者+集荷日
strSql = "SELECT * FROM orderdata_sorting WHERE pu_date Between #" & Me!pu_date_start & "# AND #" & Me!pu_date_end & "#" & " and " & naiyou
ElseIf hantei = 1101 Then ' 出荷人+業者+集荷日
strSql = "SELECT * FROM orderdata_sorting WHERE shipper ='" & Me!search_mado & "' And pu_date Between #" & Me!pu_date_start & "# AND #" & Me!pu_date_end & "#" & " and " & naiyou
ElseIf hantei = 1 Then ' 集荷日
strSql = "SELECT * FROM orderdata_sorting WHERE pu_date Between #" & Me!pu_date_start & "# AND #" & Me!pu_date_end & "#"
ElseIf hantei = 10 Then ' 配達日
strSql = "SELECT * FROM orderdata_sorting WHERE delivery_date Between #" & Me!delivery_date_start & "# AND #" & Me!delivery_date_end & "#"
' Debug.Print .Source
Else
MsgBox "設定外の抽出項目です。設定し直して再抽出してください。"
Exit Sub
End If
'エクスポート処理
flg = False
Set dbs = CurrentDb
'クエリ有無
For Each qdf In dbs.QueryDefs
If qdf.Name = "Q_Dummy" Then
flg = True
Exit For
End If
Next
'存在する場合クエリ削除
If flg = True Then
dbs.QueryDefs.Delete "Q_Dummy"
flg = False
End If
If flg = False Then
Set qdf = dbs.CreateQueryDef("Q_Dummy", strSql)
DoCmd.TransferText acExportDelim, , "Q_Dummy", FolderName & "\抽出CSV_" & Format(Now(), "yyyymmdd") & ".csv", True
dbs.Close 'dbsをクローズ
Set dbs = Nothing 'dbsを開放
Set qdf = Nothing 'qdfを開放
MsgBox "エクスポート完了しました。"
End If
End If
ExitErr_Handler:
Exit Sub
Err_Handler:
MsgBox "エラー： " & Err.description
End Sub
スゲー複雑そうに見えますが、
ココに注意
条件によって抽出したＳＱＬデータをエクスポートしているだけです
結局は、フォームのレコードソースに設定したＶＢＡコードを実行して、今回見つけたエクスポートコードを追加しただけです。