Access VBA 名前が同じテーブルにフィルターをかけて開き データを抜き出してまとめてファイルにする

設定状況

似た名前、同じ構造のテーブルが複数ある

2010年年度果物売上データテーブル
2010年年度野菜売上データテーブル
2011年年度果物売上データテーブル
2011年年度野菜売上データテーブル
2012年年度果物売上データテーブル
2012年年度野菜売上データテーブル

フィールド名、データ型、位置が同じ

2列目（アクセスのテーブルは0列目から始まるのでVBA上は1列目）がテキスト型で野菜の種類が入っている
ID、品物、単価、売り払い数量、売上高
となっている

どういうデータを抜き出すか

年度果物売上 テーブルの1列目にリンゴと入っているレコードをすべて抜き出す。
なお、リンゴだけではなく紅リンゴのような*リンゴというワイルドカードも使える。

Likeかイコールかを判定してフィルターをかける

この部分でワイルドカードの有無を判定し、あればLikeにしています。エスケープが効かないのが難点ですが。簡易な判定なのでご了承ください。
判定に使用しているのがInstrです。ワイルドカードがあれば、0以外の数字になります。
次にフィルターをかける命令がDoCmd.ApplyFilterです。

vb.net

If InStr(1, strFilter, "*", vbTextCompare) = 0 Then
DoCmd.ApplyFilter , "[" & tdf.Name & "].[" & tdf.Fields(1).Name & "] = " & "'" & strFilter & "'"
Else
DoCmd.ApplyFilter , "[" & tdf.Name & "].[" & tdf.Fields(1).Name & "] like " & "'" & strFilter & "'"
End If
DoEvents

フィルターをかけてから画面を更新する

フィルターをかけるとき画面の更新をするとバグが起きます。そこでいったんオフにします。
また画面の更新をしていなくても、今開いているテーブルがアクティブデータシートになります。
そのうえで、フィルターをかけた後、画面更新をOn、リペイントして確実にフィルターをかけます。

カレント（アクティブ）なテーブルのレコードセットを取得

このあと、スクリーン＞アクティブデータシートオブジェクトを取得します。
テーブルの場合、ActiveDataSheet.DynaSetがアクティブデータシートのレコードのセットになっています。
これをクローンすることで「フィルターがかかった状態のレコードセット」ができます。

Application.Echo True
DoCmd.RepaintObject acTable, tdf.Name: VBA.Interaction.DoEvents 'Repaint get Time to effect filter.
Set acScr = Application.Screen
Set acDataSheet = acScr.ActiveDatasheet
Set acRec2 = acDataSheet.Dynaset
Set acRec2C = acRec2.Clone

VBA 本体

Sub OpenTableOnFilter()
''''''''''''''''''''''''''''''''''''
' '                        ''
' QIIQ from QIITA ''
' '                        ''
''''''''''''''''''''''''''''''''''''
' Feture
' 1.すべてのテーブルなどを閉じる
' 2.同じ名前を含む複数のテーブルをフィルターをかけて開く。(クエリには効かない)
' 3.レコードセットをクローンする
' 4.クローンの中でレコードを回し、データを取得する
' 5.UTF-8 text File に result を output する

' Setting tdf.Field(1) Name 果物名 Value String リンゴ テーブル名 年度果物売上 という名前で終わるテーブル
'Filter String
Dim strFilter As String: strFilter = "リンゴ"


'''' Variable StateMent. -[ACCESS VBA]---------------------------------------------------------------
Dim tdf As TableDef
Dim cDB As Database: Set cDB = CurrentDb
Dim acObj
Dim sr As ADODB.Stream: Set sr = New ADODB.Stream
Dim acScr As Screen
Dim acDataSheet, i As Long, irec As Long
Dim acRec2 As Recordset2
Dim acRec2C As Recordset2
Dim buf As String
DoCmd.Minimize
DoCmd.Hourglass True
Const OpenTableWaitingTime = 500 ' If do not work well, grow up エラーが出る場合は増加してください
'''' Close Object. -[ACCESS VBA]---------------------------------------------------------------
For Each acObj In CurrentData.AllTables
If acObj.IsLoaded = True Then DoCmd.Close acTable, acObj.Name, acSaveNo
Next
For Each acObj In CurrentData.AllQueries
If acObj.IsLoaded = True Then DoCmd.Close acTable, acObj.Name, acSaveNo
Next
On Error Resume Next
For Each acObj In CurrentProject.AllForms
DoCmd.Close acForm, acObj.Name, acSaveNo
Next
For Each acObj In CurrentProject.AllMacros
DoCmd.Close acMacro, acObj.Name, acSaveNo
Next
For Each acObj In CurrentProject.AllReports
DoCmd.Close acReport, acObj.Name, acSaveNo
Next
On Error GoTo 0

sr.Charset = "utf-8"
sr.Mode = adModeReadWrite
sr.LineSeparator = adCRLF
sr.Type = adTypeText
sr.Open
On Error GoTo Terminator
For Each tdf In cDB.TableDefs
Application.Echo False
If tdf.Name Like "*年度果物売上データテーブル" Then
DoCmd.OpenTable tdf.Name, acViewNormal
DoEvents
Sleep OpenTableWaitingTime
'Setting tdf.Field(1) Name 果物名 Value String リンゴ
'''' SQL Wildcard or Equal Select
If InStr(1, strFilter, "*", vbTextCompare) = 0 Then
DoCmd.ApplyFilter , "[" & tdf.Name & "].[" & tdf.Fields(1).Name & "] = " & "'" & strFilter & "'"
Else
DoCmd.ApplyFilter , "[" & tdf.Name & "].[" & tdf.Fields(1).Name & "] like " & "'" & strFilter & "'"
End If
DoEvents
Sleep OpenTableWaitingTime
Application.Echo True
DoCmd.RepaintObject acTable, tdf.Name: VBA.Interaction.DoEvents 'Repaint get Time to effect filter.
Set acScr = Application.Screen
Set acDataSheet = acScr.ActiveDatasheet
Set acRec2 = acDataSheet.Dynaset
Set acRec2C = acRec2.Clone
sr.WriteText tdf.Name & "," & "result" & "," & "recordCnt :" & DCount("*", Application.CurrentObjectName) & "," & "SelTop:" & Application.Screen.ActiveDatasheet.SelTop & "," & "SelLeft:" & Application.Screen.ActiveDatasheet.SelLeft & "," & "recCnt:" & Application.Screen.ActiveDatasheet.Recordset.RecordCount & vbCrLf, adWriteChar
If Application.Screen.ActiveDatasheet.Recordset.RecordCount > 0 Then
acRec2C.MoveFirst
For irec = 1 To Application.Screen.ActiveDatasheet.Recordset.RecordCount
For i = 1 To acRec2C.Fields.Count
buf = buf & acRec2C.Fields(i - 1).Value & ","
Next
sr.WriteText buf & vbCrLf, adWriteChar
buf = ""
acRec2C.MoveNext
Next irec
End If
End If
Next
With CreateObject("Scripting.FileSystemObject")
'If .FileExists("C:\hoge\FilterRst.txt") = True Then .DeleteFile "C:\hoge\FilterRst.txt"
If .FileExists(CurrentProject.Path & "\" & "FilterRst.txt") = True Then .DeleteFile CurrentProject.Path & "\" & "FilterRst.txt"
End With
'sr.SaveToFile "C:\hoge\FilterRst.txt", adSaveCreateNotExist
sr.SaveToFile CurrentProject.Path & "\" & "FilterRst.txt", adSaveCreateNotExist
GoTo Finally
Exit Sub
Finally:
On Error Resume Next
sr.Close
Set sr = Nothing
Application.Echo True
DoCmd.Maximize
DoCmd.Hourglass False
Exit Sub
Terminator:
If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description: Err.Clear: Resume Finally
End Sub

クエリはこれができない

　なお、クエリの場合、ローカルウィンドでactivedatasheetを見るとDynasetはあるのですが、実際はVBAでは取り出せません。したがってこのVBAはテーブルのみに有効です。
ここがクエリとテーブルの違いです。

単一のテーブル/クエリの場合

Accessで並べ替えやフィルターの条件を保存する方法 - dekiru.net
単一のテーブルやクエリの場合、フィルターをかけると、アクセスの機能でクエリを作成し、保存することができます。