在VBA中设置查找下一个和查找上一个按钮

Question

我在Excel 2007中使用userform来自动填充表单时遇到问题。它适用于第一个条目，但我无法使用“下一步”按钮来提取符合搜索条件的下一个条目。

userform将输入参与者信息，我希望用户能够使用userform搜索与搜索条件匹配的所有条目，因此如果参与者具有相同的名称，他们可以找到正确的参与者。

这是我到目前为止所拥有的;

Private Sub FindButton_Click() ' find entry

    Set r = Sheet4.Range("B:B").Find(What:=Firstname.Text, lookat:=xlWhole, MatchCase:=False)

    If Not r Is Nothing Then
        '// Get value in cell r.row, column 2 into textbox2
        Lastname.Text = Sheet4.Cells(r.Row, 3).Value
        age.Text = Sheet4.Cells(r.Row, 4).Value
        Gender.Text = Sheet4.Cells(r.Row, 5).Value
        Grade.Text = Sheet4.Cells(r.Row, 6).Value
        Discepline.Text = Sheet4.Cells(r.Row, 7).Value
        shoesize.Text = Sheet4.Cells(r.Row, 8).Value
        HT.Text = Sheet4.Cells(r.Row, 9).Value
        Weight.Text = Sheet4.Cells(r.Row, 10).Value
        Skier.Text = Sheet4.Cells(r.Row, 11).Value
        Ability.Text = Sheet4.Cells(r.Row, 12).Value
        Lessons.Value = Sheet4.Cells(r.Row, 13).Value
        Rentals.Value = Sheet4.Cells(r.Row, 14).Value
        LiftPass.Value = Sheet4.Cells(r.Row, 15).Value
        Helmet.Value = Sheet4.Cells(r.Row, 16).Value
     End If

    If Firstname = "" Then MsgBox "Enter first name!"


End Sub


Private Sub nxt_Click() 'Commandbutton "find next"
    Dim Rng As Range
    Dim Found1 As Boolean

    If Found1 = False Then
        Set Rng = Columns(2).Find(Me.Firstname.Value, Rng, xlValues, xlWhole, xlByRows)
        Found1 = True
    Else
        Set Rng = Columns(2).FindNext(Rng)
    End If

    If Not Rng Is Nothing Then
        Lastname.Text = Sheet4.Cells(r.Row, 3).Value
        age.Text = Sheet4.Cells(r.Row, 4).Value
        Gender.Text = Sheet4.Cells(r.Row, 5).Value
        Grade.Text = Sheet4.Cells(r.Row, 6).Value
        Discepline.Text = Sheet4.Cells(r.Row, 7).Value
        shoesize.Text = Sheet4.Cells(r.Row, 8).Value
        HT.Text = Sheet4.Cells(r.Row, 9).Value
        Weight.Text = Sheet4.Cells(r.Row, 10).Value
        Skier.Text = Sheet4.Cells(r.Row, 11).Value
        Ability.Text = Sheet4.Cells(r.Row, 12).Value
        Lessons.Value = Sheet4.Cells(r.Row, 13).Value
        Rentals.Value = Sheet4.Cells(r.Row, 14).Value
        LiftPass.Value = Sheet4.Cells(r.Row, 15).Value
        Helmet.Value = Sheet4.Cells(r.Row, 16).Value
    Else
        MsgBox "No Participant Found."
    End If
End Sub

Answer 1

以下是我可能会做这样的事情 - 作为一般方法。 （未经测试但你应该明白......）

Option Explicit

Dim hits As Collection 'all matches as a collection of rows
Dim hitsPos As Long    'current position in matches

Sub FindButton_Click()

    Me.nxt.Enabled = False
    Set hits = FindAll(Sheet4.Range("B:B"), Firstname.Text)
    If hits.Count > 0 Then
        Me.nxt.Enabled = hits.Count > 1 'enable/disable "next" button
        hitsPos = 1
        LoadRow hits(hitsPos)
    Else
        MsgBox "No matches for '" & Firstname.Text & "'"
    End If
End Sub

Sub nxt_Click()
    If hitsPos < hits.Count Then
        hitsPos = hitsPos + 1
        LoadRow hits(hitsPos)
        Me.nxt.Enabled = hits.Count > hitsPos 'disable if last hit
    End If
End Sub

'load a record from the sheet
Sub LoadRow(rw As Range)
    With rw
        Firstname.Text = .Cells(2).Value
        Lastname.Text = .Cells(3).Value
        age.Text = .Cells(4).Value
        'etc etc
    End With
End Sub

'save a record to the sheet
Sub SaveRow(rw As Range)
    With rw
        .Cells(2).Value = Firstname.Text
        .Cells(3).Value = Lastname.Text
        .Cells(4).Value = age.Text
        'etc etc
    End With
End Sub

'find all matching rows and return as a collection object
Public Function FindAll(rng As Range, val As String) As Collection
    Dim rv As New Collection, f As Range
    Dim addr As String

    Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.Count), _
        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False)
    If Not f Is Nothing Then addr = f.Address()

    Do Until f Is Nothing
        rv.Add f.EntireRow '<< add the whole row...
        Set f = rng.FindNext(after:=f)
        If f.Address() = addr Then Exit Do
    Loop

    Set FindAll = rv
End Function