| |
いつもお世話になります。
ソースコードの中に、誤りがありましたので訂正します。
コマンド41_Click()時のソースをフィールド名を表示する場所に、
エイリアスを挿入したのですが、エラー表示がかわりません。
お手数ですが、ご教授をよろしくお願いします。
以上、よろしくお願いします。
'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 TEST_TABLE "
Case 2
strSQL = "select TEST_TABLE.[COMM], TEST_TABLE.[A], TEST_TABLE.[C], " _
& "TEST_TABLE.[G], TEST_TABLE.[D], TEST_TABLE.[E], TEST_TABLE.[F], " _
& "TEST_TABLE.[H], TEST_TABLE.[コメント] " _
& "from TEST_TABLE " _
& "WHERE (((TEST_TABLE.E) In (SELECT [E] FROM [TEST_TABLE] As Tmp GROUP BY [E] HAVING Count(*)>1 )) AND ((TEST_TABLE.E)<>""""))" _
& "ORDER BY TEST_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 TEST_TABLE.[A] "
strSQL = strSQL & " , TEST_TABLE.[B] AS テスト "
strSQL = strSQL & " , TEST_TABLE.[C] AS 物品名 "
strSQL = strSQL & " , TEST_TABLE.[D] AS 名1 "
strSQL = strSQL & " , TEST_TABLE.[E] AS アドレス "
strSQL = strSQL & " , TEST_TABLE.[F] AS 機会 "
strSQL = strSQL & " , TEST_TABLE.[G] As 名3 "
strSQL = strSQL & " , TEST_TABLE.[H] As 使用者 "
strSQL = strSQL & " , TEST_TABLE.[コメント] "
strSQL = strSQL & " , TEST_TABLE.[I] "
strSQL = strSQL & " , TEST_TABLE.[J] "
strSQL = strSQL & " , TEST_TABLE.[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
-----------------------------------------------------------
▼247b さん：
>おつかれさまです。
>
>frmRecSourceプロシージャのCase文の、
>case1の場合は問題なく、
>case2の場合に問題あり、ということでよろしいでしょうか。
>
>とりあえず、さっとテストしてみただけなのですが、
>コマンド41_ClickプロシージャのSQL生成ロジックで、FROM句にしているSQLに対してエイリアス
>が必要ではないかと思われます。このため、SELECT句の各項目にもエイリアスが必要です。
>
>SELECT句を「＊」で指定した場合は、問題ないようなのですが、
>SELECT句をカラム名で指定した場合、そのSELECT文をFROM句にネスト（入れ子）させると
>構文エラーが発生するようです。
|
|
VBA初心者
- 10/4/5(月) 10:36 -
![[未読]](./data/access/image/read_icon.gif){kind=icon}
