VBA UserForm複数のレコードを検索し、表示して循環する

Question

私はシート上の一意のIDを検索し、同じ行にある関連データを表示するuserformを作成しています。

私は別のStackOverflowの質問の助けを使用しましたが、私が探してるのユニークなIDに複数のデータセットがありますが、私にとってまさに

を働いていません。下のコードはfindをクリックすると最初に見つかったレコードを表示し、シートにいくつのレコードがあるかをユーザーに知らせるメッセージボックスが表示されます。 [OK]をクリックすると、ユーザーフォームが閉じます。

[OK]をクリックした後、ユーザーが[FindNext]ボタンをクリックすると、元の検索と一致する他のすべてのレコードが表示されます。 （updateFieldsでanchorCell.Select参照）FindNext_Clickのコードは、最後の行が現在の選択となるように設定したことを示しているという事実を利用

Private Sub FindNext_Click() 
    Dim nextCell As Range 
    Set nextCell = Cells.FindNext(After:=ActiveCell) 
    'FindNext loops round to the initial cell if it finds no other so we test for it 
    If Not nextCell.Address(external:=True) = ActiveCell.Address(external:=True) Then 
     updateFields anchorCell:=nextCell 
    End If 
End Sub 

Private Sub Find_Click() 
    Worksheets("Master").Activate 
    Dim strFind As String 
    Dim FirstAddress As String 
    Dim rSearch As Range 
    Set rSearch = Range("a1", Range("a65536").End(xlUp)) 
    Dim f  As Integer 
    Dim c As Object 

    strFind = Me.TextBox1.Value 

    With rSearch 
     Set c = .Find(strFind, LookIn:=xlValues) 
     If Not c Is Nothing Then 
      updateFields anchorCell:=c 
      FirstAddress = c.Address 
      Do 
       f = f + 1 
       Set c = .FindNext(c) 
      Loop While Not c Is Nothing And c.Address <> FirstAddress 
      If f > 1 Then 
       Select Case MsgBox("There are " & f & " instances of " & strFind, vbOKCancel Or vbExclamation Or vbDefaultButton1, "Multiple entries") 

        Case vbOK 
        Case vbCancel 

       End Select 
       Me.Height = frmMax 

      End If 
     Else: MsgBox strFind & " not listed" 
     End If 
    End With 

End Sub 


Private Sub updateFields(anchorCell As Range) 
anchorCell.Select 
With Me 
    .TextBox2.Value = anchorCell.Offset(0, 2).Value 
    .TextBox3.Value = anchorCell.Offset(0, 3).Value 
    .TextBox4.Value = anchorCell.Offset(0, 4).Value 
    .TextBox6.Value = anchorCell.Offset(0, 13).Value 
    .TextBox7.Value = anchorCell.Offset(0, 14).Value 
    .TextBox8.Value = anchorCell.Offset(0, 15).Value 
    .TextBox9.Value = anchorCell.Offset(0, 16).Value 
    .TextBox10.Value = anchorCell.Offset(0, 17).Value 
    .TextBox11.Value = anchorCell.Offset(0, 18).Value 
    .TextBox12.Value = anchorCell.Offset(0, 19).Value 
    .TextBox13.Value = anchorCell.Offset(0, 20).Value 
    .TextBox14.Value = anchorCell.Offset(0, 21).Value 
    .TextBox20.Value = anchorCell.Offset(0, 22).Value 
End With 
End Sub 

おかげ

Answer 1

：以下

コードです。問題は、これらの呼び出しの間にユーザーが別のセルまたは別のワークシートを選択した可能性があり、実行時エラーが発生することです。

私は2つだけの機能、マッチをカウントし、検索を開始し1、それがやや困難になります更新の責任ともう少し情報がない「

Option Explicit 
Private anchor As Range ' keeps track of the last shown row 

Private Sub Find_Click() 
    ' Only Displays the number of matches and delegates the updating to FidNext 
    Dim count As Long 
    count = WorksheetFunction.CountIf(Worksheets("Master").UsedRange.Columns("A"), TextBox1.Value) 
    If count < 1 Then 
     msgBox TextBox1.Value & " not listed" 
     FindNext.Enabled = False 
     Exit Sub 
    End If 
    FindNext.Enabled = True 
    Set anchor = Worksheets("Master").Range("A65536").End(xlUp) 
    FindNext_Click ' Now delegate the work to FindNext 
End Sub 

Private Sub FindNext_Click() 
'responsible of updating the userform and scrolling to the next field 
    Set anchor = Worksheets("Master").UsedRange.Columns("A").Find(TextBox1.Value, anchor) 

    TextBox2.Value = anchor.offset(0, 2).Value 
    TextBox3.Value = anchor.offset(0, 3).Value 
    TextBox4.Value = anchor.offset(0, 4).Value 
    TextBox6.Value = anchor.offset(0, 13).Value 
    TextBox7.Value = anchor.offset(0, 14).Value 
    TextBox8.Value = anchor.offset(0, 15).Value 
    TextBox9.Value = anchor.offset(0, 16).Value 
    TextBox10.Value = anchor.offset(0, 17).Value 
    TextBox11.Value = anchor.offset(0, 18).Value 
    TextBox12.Value = anchor.offset(0, 19).Value 
    TextBox13.Value = anchor.offset(0, 20).Value 
    TextBox14.Value = anchor.offset(0, 21).Value 
    TextBox20.Value = anchor.offset(0, 22).Value 

    Worksheets("Master").Activate 
    anchor.EntireRow.Activate 
End Sub