continuous loop using Find in Excel VBA

Question

I have the below code, which I am having trouble with:

Sub getAccNos()

Dim oNameRange As Range
Dim oFindRng As Range

Dim sName As String
Dim sAccNo As Stri         


        

Answer 1

Here is a simple code which doesn't loop through Sheet1 cells to find a match. It uses .FIND and .FINDNEXT. More about it HERE.

Place this code in a module and simply run it. This code is based on your sample file.

Sub Sample()
    Dim wsI As Worksheet, wsO As Worksheet
    Dim lRow As Long, i As Long
    Dim sAcNo As String
    Dim aCell As Range, bCell As Range

    '~~> This is the sheet which has account numbers
    Set wsI = ThisWorkbook.Sheets("Sheet1")
    '~~> This is the sheet where we need to populate the account numbers
    Set wsO = ThisWorkbook.Sheets("Sheet2")

    With wsO
        lRow = .Range("B" & .Rows.Count).End(xlUp).Row

        .Range("A1:A" & lRow).NumberFormat = "@"

        For i = 2 To lRow
            Set aCell = wsI.Columns(2).Find(What:=.Range("B" & i).Value, _
                        LookIn:=xlValues, LookAt:=xlPart, _
                        SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                        MatchCase:=False, SearchFormat:=False)

            If Not aCell Is Nothing Then
                Set bCell = aCell
                sAcNo = sAcNo & "," & aCell.Offset(, -1).Value

                Do
                    Set aCell = wsI.Columns(2).FindNext(After:=aCell)

                    If Not aCell Is Nothing Then
                        If aCell.Address = bCell.Address Then Exit Do
                        sAcNo = sAcNo & "," & aCell.Offset(, -1).Value
                    Else
                        Exit Do
                    End If
                Loop
            End If

            If sAcNo <> "" Then
                .Range("A" & i).Value = Mid(sAcNo, 2)
                sAcNo = ""
            End If
        Next i
    End With
End Sub

SCREENSHOT

Hope this is what you wanted?

Answer 2

Here is an example. What I would do is count how many occurrences, and then add another variable to increment for each occurrence, and Loop While Not foundCount >= howManyInRange

Sub FindInRange()

Dim howManyInRange As Long
Dim foundCount As Long
Dim oFindRange As Range
Dim rngSearch As Range
Dim srchVal As String

srchVal = "Steve"
Set rngSearch = Range("D:D")

'## First, check to see if the value exists.'

howManyInRange = Application.WorksheetFunction.CountIf(rngSearch, srchVal)

If Not howManyInRange = 0 Then
    Do
        Set oFindRange = rngSearch.Find(what:=srchVal, After:=ActiveCell)
        '## Avoid duplicate and infinite loop:'
        foundCount = foundCount + 1
        oFindRange.Activate
        '## Do your stuff, here.'

        Debug.Print oFindRange.Address

    Loop While Not foundCount >= howManyInRange
End If

End Sub

Answer 3

I really really wanted to create something cool, sexy, snazzy, showy, elegant and clever using a Formula because I could, only it turned out that I couldn't, then it turned out I couldn't even get my Find logic to work, so I did it with a couple of nested loops then checked the results with formulas!

Sub getAccNos()

Dim oNameRange As Range
Dim oFindRng As Range

Dim sName As String
Dim sAccNo As String

Application.ScreenUpdating = False
Set oNameRange = Workbooks("New Name Work.xls").Worksheets("Manual").Range("B4")

Do While Not oNameRange.Text = ""
    sName = Trim(oNameRange.Text)
    Workbooks("New Name Work.xls").Worksheets("sheet1").Select
    Range("C2").Select
    Do Until activecell.Text = ""
        If Trim(activecell.Text) = sName Then
            Do
                oNameRange.Offset(0, -1).Value = activecell.Offset(0, 1).Text
                Set oNameRange = oNameRange.Offset(1, 0)
                activecell.Offset(1, 0).Select
            Loop While activecell.Text = sName
            GoTo NextName
        Else
            activecell.Offset(1, 0).Select
        End If
    Loop
NextName:
Application.StatusBar = "Row " & oNameRange.Row & " (" & oNameRange.Text & ")"
Loop
Application.ScreenUpdating = True
End Sub