DAO 条件に一致するレコードを取得(Findメソッド)エクセル連携サンプル
※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。
※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。
Sub DAO_Find_Record_Sample() '*********************************************** 'DAO 条件に一致するレコードを取得(Findメソッド) '*********************************************** '[Microsoft DAO 3.6 Object Library]参照設定 'エクセル連携サンプル(122,852個からのデータ検索) Dim objDtbs As DAO.Database Dim objRcrd As DAO.Recordset Dim strTblName As String Dim strFilePath As String Dim strFileName As String Dim strFindFieldName As String Dim strMatchFieldName(4) As String Dim strSeek As String Dim strSQL As String Dim strMSG As String, h As Long strFilePath = ThisWorkbook.Path 'ファイルのパス strFileName = "KEN_ALL.mdb" 'ファイル名 strTblName = "KEN_ALL" 'テーブル名 strFindFieldName = "フィールド3" '検索フィールド名 strMatchFieldName(1) = "フィールド3" '検索結果フィールド名 strMatchFieldName(2) = "フィールド7" '検索結果フィールド名 strMatchFieldName(3) = "フィールド8" '検索結果フィールド名 strMatchFieldName(4) = "フィールド9" '検索結果フィールド名 strSeek = "0600008" '検索文字 Dim sht As Worksheet Set sht = ThisWorkbook.Worksheets("Sheet2") '【エラートラップ】 On Error GoTo ThisERR: '【データベースを開く】 Set objDtbs = OpenDatabase(strFilePath & "\" & strFileName) '【指定テーブルのレコード取得】 Set objRcrd = objDtbs.OpenRecordset(strTblName) For h = 2 To sht.Cells(65536, 6).End(xlUp).Row strSeek = sht.Cells(h, 6).Value strSeek = Trim(strSeek) If strSeek = "" Then GoTo endLoop: If Len(strSeek) = 8 Then strSeek = Mid(strSeek, 1, 3) & Mid(strSeek, 5) Else GoTo endLoop: End If objRcrd.FindFirst strFindFieldName & "=" & "'" & strSeek & "'" If objRcrd.NoMatch = False Then sht.Cells(h, 9).Value = objRcrd.Fields(strMatchFieldName(2)) sht.Cells(h, 10).Value = objRcrd.Fields(strMatchFieldName(3)) sht.Cells(h, 11).Value = objRcrd.Fields(strMatchFieldName(4)) Else ' MsgBox "見つかりません", 0, strSeek End If endLoop: Next h '-------------------------------------------------------------- 'メソッド | 開始位置 | 検索方向 | 用途 '---------------|-----------|-----------|----------------- 'FindFirst | 先頭 | 終端 | カレント 'FindLast | 終端 | 先頭 | カレント 'FindNext | カレント | 終端 | 複数存在 'FindPrevious | カレント | 先頭 | 複数存在 '---------------|-----------|-----------|----------------- 'プロパティ | 検索成功 | 検索失敗 | '---------------|-----------|-----------|----------------- 'NoMatch | False | True | '---------------|-----------|-----------|----------------- '演算子 | =,<,>,<=,>= '-------------------------------------------------------------- '【レコードを閉じる】 objRcrd.Close '【データベースを閉じる】 objDtbs.Close ' 【オブジェクト解放】 Set objRcrd = Nothing Set objDtbs = Nothing MsgBox "END!", 0, "FIND" Exit Sub '【エラートラップ】 ThisERR: MsgBox "予期せぬエラーが発生しました。" & vbCrLf & Err.Description, vbCritical, "ErrNumber:" & Err.Number End Sub |