Access VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

1714 / 9994

←次へ　｜　前へ→


	【11571】フィルタ適用後のEXCEL出力時について

VBA初心者 - 10/4/2(金) 17:08 -


	引用なし

	パスワード

いつもお世話になります。
　下記のコマンドにてフレームを作成して、条件毎にフォーム上に表示させております。（1.2.）
その他、3.のように別の条件でも抽出して、フォーム上のデータをフィルタかけた状態で
エクセルに出力するようにしております。
　しかし、一度1.2.を実行した後、3.を実行すると、「実行時エラー'3131'FROM句の構文エラーです。」
と表示されてしまいます。
　1.2.を実行しないで3.を実行すると、何もエラーが出ないでEXCELに出力されます。
どこが間違っているのか解りません。
　どうかご教授をお願い致します。　　

'1.「表示」ボタンクリック時-----------------------------------------------------------

Private Sub コマンド36_Click()

Me.RecordSource = frmRecSource
　　Me.Requery

End Sub
-----------------------------------------------------------

'2.オプション抽出条件-----------------------------------------------------------
Function frmRecSource() As String
　　Dim strSQL As String
　　
　　Select Case Me.フレーム54
　　Case 1
　　　　strSQL = "select *　" _
　　　　　　& "from TOHO_TABLE "
　　Case 2
　　　　 strSQL = "select TOHO_TABLE.[COMM], TOHO_TABLE.[A], TOHO_TABLE.[C],　" _
　　　　　　& "TOHO_TABLE.[G], TOHO_TABLE.[D], TOHO_TABLE.[E], TOHO_TABLE.[F], " _
　　　　　　& "TOHO_TABLE.[H], TOHO_TABLE.[コメント] " _
　　　　　　& "from TOHO_TABLE　" _
　　　　　　& "WHERE (((TOHO_TABLE.E) In (SELECT [E] FROM [TOHO_TABLE] As Tmp GROUP BY [E] HAVING Count(*)>1 )) AND ((TOHO_TABLE.E)<>""""))" _
　　　　　　& "ORDER BY TOHO_TABLE.E DESC "

　　End Select
　　
　　Debug.Print strSQL
　　frmRecSource = strSQL
　　
End Function

-----------------------------------------------------------

'3.エクセル出力-----------------------------------------------------------
Private Sub コマンド41_Click()
　
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Dim strWhere As String
Dim xlsApp As Object
Dim xlsWkb As Object
Dim xlsFileName As String
Dim i As Long

Dim myDir As String　'デスクトップ定数

　　'フィルタを掛けた時点で Hitするものがなかったような場合は
　　'メッセージを出して処理を中止します。
　　If Me.Recordset.EOF Then
　　　　MsgBox Prompt:="出力するデータがありませぬ" _
　　　　　　 , Buttons:=vbExclamation
　　　　Exit Sub
　　End If
　　
　　'デスクトップを指定
　　myDir = CreateObject("WScript.Shell").SpecialFolders("Desktop")

　　Set db = CurrentDb
　　xlsFileName = myDir & "\" & Format(Date, "yyyy_mm_dd") & "一覧表.xls"

　　'もし Filterプロパティになにも記述されていなかったら
　　'フォームに表示されている全データを出力するようにします。
　　If Me.Filter = "" Then
　　　　strWhere = True
　　Else
　　　　strWhere = Me.Filter
　　End If

'解除ボタンを押した場合は、全データを出力するようにします。
　　If Me.FilterOn = False Then
　　　　strWhere = True
　　 End If
　
　　'変数に SQL文を代入します。
　　'Filter プロパティに記述されているものを抽出条件とします。

　　strSQL = ""
　　strSQL = strSQL & " SELECT A "
　　strSQL = strSQL & " , COMM AS B "
　　strSQL = strSQL & " , C AS 物品名 "
　　strSQL = strSQL & " , D AS 名1 "
　　strSQL = strSQL & " , E AS アドレス "
　　strSQL = strSQL & " , F AS 機会 "
　　strSQL = strSQL & " , G As 名3 "
　　strSQL = strSQL & " , H As 使用者 "
　　strSQL = strSQL & " , コメント "
　　strSQL = strSQL & " , I "
　　strSQL = strSQL & " , J "
　　strSQL = strSQL & " , K "
　　strSQL = strSQL & " FROM " & Me.RecordSource & " "
　　strSQL = strSQL & " WHERE " & strWhere
　　strSQL = strSQL & " ORDER BY COMM DESC"　'Bを降順で並べ替える

　　
　　'レコードセットに対象のデータを代入します
　　Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)

　　'以下Excelの操作------------------------------------------
　　Set xlsApp = CreateObject("Excel.Application")
　　　　xlsApp.Visible = True
　
　　Set xlsWkb = xlsApp.workbooks.Add
　　　　With xlsWkb.Sheets("Sheet1")

　　　　 For i = 0 To rs.Fields.Count - 1
　　　　　　 .Range("A1").Offset(0, i).Value = rs.Fields(i).Name
　　　　　　 Debug.Print rs.Fields(i).Name
　　　　 Next i
　　
　　　　.Range("A2").CopyFromRecordset rs
　　　　.columns("A:K").AutoFit
　　　　End With
　　
　　
　　xlsWkb.SaveAs xlsFileName, FileFormat:=56
　　xlsWkb.Close: Set xlsWkb = Nothing
　　xlsApp.Quit: Set xlsApp = Nothing
　
　　MsgBox "出力しました!!"

　　
End Sub
-----------------------------------------------------------

887 hits

▼

【11571】フィルタ適用後のEXCEL出力時について VBA初心者 10/4/2(金) 17:08