Как использовать цикл «Для каждого» в vba?

Question

Sub Findnext() 
Dim Name As String 
Dim f As range 
Dim ws As Worksheet 
Dim s As Integer 

Name = surname.Value 
'currently only searching one instance...doesn't loop and find the rest 
Me.ListBox1.Clear 
    Set f = Cells.Find(what:=Name, LookIn:=xlValues) 
    Set findnext = f 
With ListBox1 
    Do 
    Debug.Print findnext.Address 
    Set findnext = Cells.findnext(findnext) 
     .AddItem f.Value 
     .List(0, 1) = f.Offset(0, 1).Value 
     .List(0, 2) = f.Offset(0, 2).Value 
     .List(0, 3) = f.Offset(0, 3).Value 
     .List(0, 4) = f.Offset(0, 4).Value 
     .List(0, 5) = f.Offset(0, 5).Value 
     .List(0, 6) = f.Offset(0, 6).Value 
    Loop While findnext.Address <> f.Address 
    End With 
End Sub 

Как сделать этот цикл кода так, чтобы он нашел несколько значений f? Essentailly, у меня есть кнопка поиска, и она предлагает «Есть 3 экземпляра», а в поле списка должно быть указано три экземпляра (например, одно и то же имя).

Я попытался с помощью Для каждого ф и следующих е в коде выше, но он все еще только выбирает один f.value и не выбрать любые другие клетки с таким же именем ....

EDIT: я 've добавил функцию цикла, но теперь в списке, он отображает только имя человека, а не перечисляет все значения смещения. это смещение, не применяемое к циклу? или это потому, что он ищет только f? какой имя он ищет?

EDIT: кодирование я сделал до сих пор ...

Private Sub CommandButton1_Click() 
MsgBox "Directorate has been added", vbOKOnly 

Dim ctrl As control 
    For Each ctrl In UserForm1.Controls 
    If TypeName(ctrl) = "CheckBox" Then 
     'Pass this CheckBox to the subroutine below: 
    TransferValues ctrl 
    End If 
    Next 

TransferMasterValue End Sub

Sub TransferValues(cb As MSForms.CheckBox) 
Dim ws As Worksheet 
Dim emptyRow As Long 

If cb Then 
    'Define the worksheet based on the CheckBox.Name property: 
    Set ws = Sheets(Left(cb.Name, 15)) 
    emptyRow = WorksheetFunction.CountA(ws.range("A:A")) + 1 
     With ws 
      .Cells(emptyRow, 1).Value = surname.Value 
      .Cells(emptyRow, 2).Value = firstname.Value 
      .Cells(emptyRow, 3).Value = tod.Value 
      .Cells(emptyRow, 4).Value = program.Value 
      .Cells(emptyRow, 5).Value = email.Value 
      .Cells(emptyRow, 6).Value = officenumber.Value 
      .Cells(emptyRow, 7).Value = cellnumber.Value 
     End With 

    End If 
End Sub 

Sub TransferMasterValue() 
Dim allChecks As String 
Dim ws As Worksheet 
    'Iterate through the checkboxes concatenating a string of all names 
For Each ctrl In UserForm1.Controls 
    If TypeName(ctrl) = "CheckBox" Then 
    If ctrl Then 
     allChecks = allChecks & ctrl.Name & "" 

    End If 
    End If 
Next 

'If you have at least one transfer to the Master sheet 
    If Len(allChecks) > 0 Then 
    Set ws1 = Sheets("Master") 
    emptyRow = WorksheetFunction.CountA(range("A:A")) + 1 

    With ws1 
     .Cells(emptyRow, 1).Value = surname.Value 
     .Cells(emptyRow, 2).Value = firstname.Value 
     .Cells(emptyRow, 3).Value = tod.Value 
     .Cells(emptyRow, 4).Value = program.Value 
     .Cells(emptyRow, 5).Value = email.Value 
     .Cells(emptyRow, 7).Value = officenumber.Value 
     .Cells(emptyRow, 8).Value = cellnumber.Value 
     .Cells(emptyRow, 6).Value = Left(allChecks, Len(allChecks) - 1) 
    End With 
    End If 
End Sub 

Private Sub CommandButton2_Click() 
Unload UserForm1 
End Sub 

Private Sub CommandButton3_Click() 
surname.Value = "" 
firstname.Value = "" 
tod.Value = "" 
program.Value = "" 
email.Value = "" 
officenumber.Value = "" 
cellnumber.Value = "" 
PACT.Value = False 
PrinceRupert.Value = False 
WPM.Value = False 
Montreal.Value = False 
TET.Value = False 
TC.Value = False 
US.Value = False 
Other.Value = False 
End Sub 

Private Sub ListBox1_Click() 
Dim r As Long 
With Me.ListBox1 

    With Me 
    .surname.Value = .ListBox1.List(.ListBox1.ListIndex, 0) 
    .firstname.Value = .ListBox1.List(.ListBox1.ListIndex, 1) 
    .tod.Value = .ListBox1.List(.ListBox1.ListIndex, 2) 
    .program.Value = .ListBox1.List(.ListBox1.ListIndex, 3) 
    .email.Value = .ListBox1.List(.ListBox1.ListIndex, 4) 
    .officenumber.Value = .ListBox1.List(.ListBox1.ListIndex, 5) 
    .cellnumber.Value = .ListBox1.List(.ListBox1.ListIndex, 6) 
    End With 
End With 
End Sub 

Private Sub Search_Click() 'only searches in master tab right now need to search from all worksheets 
Dim Name As String 
Dim f As range 
Dim r As Long 
Dim ws As Worksheet 
Dim s As Integer 
Dim FirstAddress As String 

    Name = surname.Value 

    With ws 
     Set f = range("A:A").Find(what:=Name, LookIn:=xlValues) 
     If Not f Is Nothing Then 
    With Me 
     firstname.Value = f.Offset(0, 1).Value 
     tod.Value = f.Offset(0, 2).Value 
     program.Value = f.Offset(0, 3).Value 
     email.Value = f.Offset(0, 4).Text 
     officenumber.Value = f.Offset(0, 5).Text 
     cellnumber.Value = f.Offset(0, 6).Text 
    End With 
    findnext 
     FirstAddress = f.Address 
Do 
    s = s + 1 
    Set f = range("A:A").findnext(f) 
      Loop While Not f Is Nothing And f.Address <> FirstAddress 
    If s > 1 Then 
     Select Case MsgBox("There are " & s & " instances of " & Name, vbOKCancel Or vbExclamation Or vbDefaultButton1, "Multiple entries") 

     Case vbOK 
      findnext 
     Case vbCancel 
     End Select 

    End If 

Else: MsgBox Name & "Not Listed" 
End If 
End With 

End Sub 

Sub findnext() 
Dim Name As String 
Dim f As range 
Dim ws As Worksheet 
Dim s As Integer 
Dim findnext As range 

    Name = surname.Value 
    Me.ListBox1.Clear 
    Set f = range("A:A").Find(what:=Name, LookIn:=xlValues) 
    Set findnext = f 

     With ListBox1 
    Do 
     Debug.Print findnext.Address 
     Set findnext = range("A:A").findnext(findnext) 
     .AddItem findnext.Value 
     .List(0, 1) = findnext.Offset(0, 1).Value 
     .List(0, 2) = findnext.Offset(0, 2).Value 
     .List(0, 3) = findnext.Offset(0, 3).Value 
     .List(0, 4) = findnext.Offset(0, 4).Value 
     .List(0, 5) = findnext.Offset(0, 5).Value 
     .List(0, 6) = findnext.Offset(0, 6).Value 
     .List(0, 7) = findnext.Offset(0, 6).Value 
    Loop While findnext.Address <> f.Address 
     End With 

End Sub 

Answer 1

Вам нужно вам Find то FindNext в цикле. Вы знаете, что вы закончили цикл, когда ваш FindNext находит первое, что вы нашли снова. Он будет так циклироваться.

Dim firstFind As Range, subsequentFinds As Range 

Set firstFind = Range("D3:D500").Find("search string", , xlValues) 

Set subsequentFinds = firstFind 
Do 
    Debug.Print subsequentFinds.Address 
    Set subsequentFinds = Cells.FindNext(subsequentFinds) 
Loop While subsequentFinds.Address <> firstFind.Address