continuous loop using Find in Excel VBA

问题:

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 String

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
    Set oFindRng = Cells.Find(What:=sName, After:=activecell)

    Do While Not oFindRng Is Nothing
        oNameRange.Offset(0, -1).Value = oFindRng.Offset(0, 1).Text
        oFindRng.Offset(1, 0).Activate
        Set oFindRng = Cells.Find(What:=sName, After:=activecell)
    Loop
    Set oNameRange = oNameRange.Offset(1, 0)
Loop
End Sub

Basically, on worksheet sheet1 I have a list of names with account number, and there can be several account numbers with the same name. On my target sheet, called Manual, I have the names .... but the account numbers are missing and I would like to get them.

I cannot use VLOOKUP because there are several names that are the same and I need to get a list of all the account numbers. How can I do this?

I tried to write the above code using FIND in VBA, unfortunately, I am missing something elementary as once in the inside Do Loop it just loops continuously when it should be stepping out (as for the first one there is only one occurrance)

thanks for showing me what I am doing wrong, or maybe a formula would be better?

回答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?

回答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

回答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