アクセス小僧：開いたクエリの特定のレコードに移動：崖の上のジョージ：So-netブログ

	ブログをはじめるログイン

アクセス小僧：開いたクエリの特定のレコードに移動　[コンピューター] [編集]

以前、フォームで開いたテーブルで、

直前に見ていたレコードに移動するマクロを紹介したと思うのですが、開いたクエリの特定のレコードに移動するマクロのできるのでは。。。と３連休中、唸ってました。。。

フォームを読み込んだとき、起動されるマクロにクエリ「全件の経過日数」を開いて、
フォームで参照しているレコードと同じIDのレコードにDoCmd.GoToRecordで移動します。

Private Sub Form_Load()
  '【イベント】フォーム読み込み時
  '【変数】
  Dim MyStr1 As String
  Dim Ans As Integer
  Dim C_PW_Mng_ID1 As String ' 現在のPW_Mng_ID1
  Dim acDataSheet
  Dim dRs2 As DAO.Recordset2
  Dim i As Long
  Dim myFlag1 As Long
  '【実行コード】
  Me.追加変更許可.Caption = "追加変更許可"
  Me.追加変更許可.BackColor = RGB(209, 234, 240)
  Me.AllowAdditions = True ' レコード追加許可
  Me.AllowEdits = True ' 変更許可
  Call USReQuery1(0) ' 再クエリ
  ' 直前に参照していたレコードに移動
  MyStr1 = "PW_Mng_ID = " & DLookup("PW_Mng_ID1", "T_PWMngID", "T_PM_ID=1")
  With Me.Recordset
    .FindFirst MyStr1
  End With
  ' クエリ「全件の経過日数」が開いているか、確認し、開いていたら、一旦閉じて、開く。
  ' 開いていなかったら、開く
  If SysCmd(acSysCmdGetObjectState, acQuery, "全件の経過日数") _
  = acObjStateOpen Then
    Ans = MsgBox("クエリ「全件の経過日数」を一旦、閉じます。", vbExclamation, "注目！")
    DoCmd.Close acQuery, "全件の経過日数"
  End If
  ' 「全件の経過日数」クエリを開き、保存しているIDのレコードへ移動
  DoCmd.OpenQuery "全件の経過日数" ' クエリを開く
  ' Debug.Print Application.CurrentObjectName
  Set acDataSheet = Application.Screen.ActiveDatasheet
  Set dRs2 = acDataSheet.RecordsetClone 'クエリ結果の全レコードを取得
  ' Debug.Print "RecordCount=" & dRs2.RecordCount
  dRs2.MoveFirst ' 先頭レコードへ
  dRs2.MoveLast ' 最終レコードへ
  dRs2.MoveFirst ' 先頭レコードへ
  C_PW_Mng_ID1 = DLookup("PW_Mng_ID1", "T_PWMngID", "T_PM_ID=1") ' 保存してあるIDを参照
  ' クエリ結果の各レコードのIDと、保存しているIDを比較して、同じIDのレコードが何番目(i)か調べる
  ' クエリ結果の最初のフィールドが、ID
  myFlag1 = 0 ' 見つかっていない
  For i = 1 To dRs2.RecordCount
    Debug.Print "i=" & i & " ID=" & dRs2.Fields(0).Value
    ' IDが一致したら、For文を抜ける
    If dRs2.Fields(0).Value = C_PW_Mng_ID1 Then
      Debug.Print "i=" & i & " ID=" & dRs2.Fields(0).Value & "(一致)"
      myFlag1 = 1 ' 見つかった
      Exit For
    End If
    If i = dRs2.RecordCount Then
      Exit For
    Else
      dRs2.MoveNext ' 次のレコードへ
    End If
  Next i
  If myFlag1 = 1 Then
    DoCmd.GoToRecord , , acGoTo, i ' IDが一致したi番目のレコードに移動
  Else
    Ans = MsgBox("ID=" & C_PW_Mng_ID1 & "が見つかりません。", vbExclamation, "注目！")
  End If
End Sub

DoCmd.GoToRecord メソッド (Access)
https://msdn.microsoft.com/ja-jp/vba/access-vba/articles/docmd-gotorecord-method-access