DAO 条件に一致するレコードを取得(Findメソッド)エクセル連携サンプル

VB&VBA
FROG ふろっぐ
 
  • オプション

    本文印刷

    お気に入りに追加

  • 検索

    Googlewwwjp-ia
     

    Googlewwwjp-ia
     
  • 情報

  • 関連

[VB&VBA][DAO 条件に一致するレコードを取得(Findメソッド)エクセル連携サンプル]
Option Explicit


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







Production Japan Import Application. Since 1998