| |
お世話になります。
下記にソースを記述します。
フレームで条件を抽出する場合と「コマンド38_Click」
をクリックした時の検索条件にて値を抽出するようにしてます。
お手数ですが、よろしくお願いします。
---------------------VBAソース-------------------------------
Private Sub コマンド36_Click()----フレームの抽出条件
Me.RecordSource = frmRecSource
Me.Requery
End Sub
Function frmRecSource() As String-----Function関数
Dim strSQL As String
Dim strWH As String
Select Case Me.フレーム54
Case 1
strSQL = "select * " _
& "from TEST_TABLE "
Case 2
strSQL = "select TEST_TABLE.[A]"
strSQL = strSQL & ", TEST_TABLE.[B]"
strSQL = strSQL & ", TEST_TABLE.[C]"
strSQL = strSQL & ", TEST_TABLE.[D]"
strSQL = strSQL & ", TEST_TABLE.[E]"
strSQL = strSQL & ", TEST_TABLE.[F]"
strSQL = strSQL & ", TEST_TABLE.[G]"
strSQL = strSQL & ", TEST_TABLE.[H]"
strSQL = strSQL & ", TEST_TABLE.[I]"
strSQL = strSQL & ", TEST_TABLE.[J]"
strSQL = strSQL & ", TEST_TABLE.[K]"
strSQL = strSQL & ", TEST_TABLE.[L]"
strSQL = strSQL & " from TEST_TABLE"
strSQL = strSQL & " WHERE (((TEST_TABLE.E In (SELECT TEST_TABLE.E FROM (SELECT COUNT(*),TEST_TABLE.E FROM TEST_TABLE As TEST_TABLE "
strSQL = strSQL & " GROUP BY TEST_TABLE.E HAVING Count(*)>1 ) AS TEST_TABLE) AND TEST_TABLE.E<>'' "
strSQL = strSQL & " ORDER BY TEST_TABLE.E DESC "
End Select
Debug.Print strSQL
frmRecSource = strSQL
End Function
Private Sub コマンド38_Click()------検索ボタン
Dim strWH As String
strWH = "(A Like '*" & Me.テキスト36 & "*')" _
& " OR (B Like '*" & Me.テキスト36 & "*')" _
& " OR (C Like '*" & Me.テキスト36 & "*')" _
& " OR (D Like '*" & Me.テキスト36 & "*')" _
& " OR (E Like '*" & Me.テキスト36 & "*')" _
& " OR (F Like '*" & Me.テキスト36 & "*')" _
& " OR (G Like '*" & Me.テキスト36 & "*')" _
& " OR (H Like '*" & Me.テキスト36 & "*')" _
& " OR (I Like '*" & Me.テキスト36 & "*')"
Me.Filter = strWH
Me.FilterOn = True
Private Sub コマンド41_Click()--------------Excel出力
'On Error GoTo Err_コマンド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 C "
strSQL = strSQL & " , A AS 事業所名 "
strSQL = strSQL & " , B AS ＰＣ名 "
strSQL = strSQL & " , D AS セグメント名 "
strSQL = strSQL & " , E AS ＩＰアドレス "
strSQL = strSQL & " , F AS 機種 "
strSQL = strSQL & " , G As ドメイン名 "
strSQL = strSQL & " , H As 使用者 "
strSQL = strSQL & " , I "
strSQL = strSQL & " , J "
strSQL = strSQL & " , K "
strSQL = strSQL & " , L "
'strSQL = strSQL & " FROM " & Me.RecordSource & " "
strSQL = strSQL & " FROM (" & Me.RecordSource & ") As TEST_TABLE"
strSQL = strSQL & " WHERE " & strWhere
'strSQL = strSQL & " ORDER BY A DESC" '名を降順で並べ替える
strSQL = strSQL & " ORDER BY TEST_TABLE.A DESC" '名を降順で並べ替える
'レコードセットに対象のデータを代入します
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 "出力しました!!"
Exit_コマンド41_Click:
Exit Sub
Err_コマンド41_Click:
MsgBox "出力できません！管理者に確認！！"
Resume Exit_コマンド41_Click
End Sub
▼247b さん：
>最新のVBAプログラムを見せてください。
|
|
VBA初心者
- 10/4/7(水) 13:53 -
![[未読]](./data/access/image/read_icon.gif){kind=icon}
