Code stops after the first match. How do I go about making it repeat?

Question

I'm working on a project and after some help, mostly on this forum, I have the following code. However where I'm stuck at is that this code stops after finding the first match. I would like it to continue finding matches and execute exactly as it is doing already.

I'm not too familiar with VBA and this code is a little complex for me. I hope I was able to explain this properly.


Dim wsImport As Worksheet

Sub Sample()
    Dim wsSpec As Worksheet
    
    Set wsImport = ThisWorkbook.Sheets("Import")
    Set wsSpec = ThisWorkbook.Sheets("Specifications")
    
    Dim CriteriaA As String, CriteriaB As String, CriteriaC As String
    Dim aCell As Range, bCell As Range
    Dim origin As String, KeyToFind As String
    
    With wsSpec
        CriteriaA = wsImport.Range("C3").Value2
        CriteriaB = wsImport.Range("C4").Value2
        CriteriaC = wsImport.Range("C5").Value2
        
        '~~> Using .Find to look for CriteriaA
        Set aCell = .Columns(8).Find(What:=CriteriaA, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
        '~~> Check if found or not
        If Not aCell Is Nothing Then
            Set bCell = aCell
            
            '~~> Secondary checks
            If aCell.Offset(, 1).Value2 = CriteriaB And _
               aCell.Offset(, 2).Value2 = CriteriaC Then '<~~ If match found
               '~~> Get the origin and the key
               origin = aCell.Offset(, 6).Value2
               KeyToFind = aCell.Offset(, 7).Value2
            Else '<~~ If match not found then search for next match
               Do
                   Set aCell = .Columns(8).FindNext(After:=aCell)
        
                   If Not aCell Is Nothing Then
                        If aCell.Address = bCell.Address Then Exit Do
                        
                        If aCell.Offset(, 1).Value2 = CriteriaB And _
                           aCell.Offset(, 2).Value2 = CriteriaC Then
                           origin = aCell.Offset(, 6).Value2
                           KeyToFind = aCell.Offset(, 7).Value2
                           Exit Do
                        End If
                   Else
                       Exit Do
                   End If
               Loop
            End If
            
            '~~> Check the origin
            If origin = "Letters" Then
                CopyRows "M", KeyToFind, True
            ElseIf origin = "Numbers" Then
                CopyRows "H", KeyToFind, False
            Else
                MsgBox "Please check origin. Numbers/Letters not found. Exiting..."
            End If
        Else
            MsgBox "Criteria A match was not found. Exiting..."
        End If
    End With
End Sub

'~~> Autofilter and copy filtered data
Private Sub CopyRows(Col As String, SearchString As String, PartialString As Boolean)
    Dim copyFrom As Range
    Dim lRow As Long
    
    With wsImport
        '~~> Remove any filters
        .AutoFilterMode = False
        
        lRow = .Range(Col & .Rows.Count).End(xlUp).Row

        With .Range(Col & "1:" & Col & lRow)
            If PartialString = False Then
                .AutoFilter Field:=1, Criteria1:=SearchString
            Else
                .AutoFilter Field:=1, Criteria1:="=*" & SearchString & "*"
            End If
            
            Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
        End With

        '~~> Remove any filters
        .AutoFilterMode = False
    End With
    
    '~~> Some sheet where you want to paste the output
    Dim SomeSheet As Worksheet
    Set SomeSheet = ThisWorkbook.Sheets("Output")
    
    If Not copyFrom Is Nothing Then
        '~~> Copy and paste to some sheet
        copyFrom.Copy SomeSheet.Rows(1)
        
        'After copying, delete the unwanted columns (OPTIONAL)
    End If
End Sub

Edit: Specifications sheet: Import sheet:

I'm trying to match 'studentnumber' (O column on specifications sheet) based on which 'studentnumber type' (N column on specifactions sheet) with their corresponding match on the import sheet. (column H or M)

can you post the input data (image of `Import` and `Specifications`) please and explain what you are expecting to match with what? thanks — JohnnieL, Feb 08 '21 at 12:44
Please go through your code step by step using F8 and check your variable values in each step to find out where it goes wrong. [Excel Easy - Debugging](https://www.excel-easy.com/vba/examples/debugging.html) — Pᴇʜ, Feb 08 '21 at 13:04
@JohnnieL I've edited my post to show both Import and Specifications sheet. — rockatheman1, Feb 08 '21 at 13:56
@Pᴇʜ there are no errors in the code. The thing is that it isn't looping like I would like to. — rockatheman1, Feb 08 '21 at 14:11
@rockatheman1 I was not speaking about errors, but if you go through the code step by step you can investigate your variable values and you can see which steps are performed and weather it goes into an `if` or into an `else` so you can see which "way" the code takes. So you can find out what's going wrong. Now that you write code the next step to learn is how to debug code (and find out what's actually going on). — Pᴇʜ, Feb 08 '21 at 14:14

Dy.Lee · Answer 1 · 2021-02-08T13:53:13.030

When using the find method, it is determined whether or not to proceed with a loop by comparing the address of the first cell found and the address of the next cell.

Sub Sample()
    Dim wsSpec As Worksheet
    
    Set wsImport = ThisWorkbook.Sheets("Import")
    Set wsSpec = ThisWorkbook.Sheets("Specifications")
    
    Dim CriteriaA As String, CriteriaB As String, CriteriaC As String
    Dim aCell As Range, bCell As Range
    Dim origin As String, KeyToFind As String
    Dim rngDB As Range
    Dim strAdress As String
    
    With wsSpec
        CriteriaA = wsImport.Range("C3").Value2
        CriteriaB = wsImport.Range("C4").Value2
        CriteriaC = wsImport.Range("C5").Value2
        
        Set rngDB = .Range("h1", .Range("h" & Rows.Count).End(xlUp))
        
        '~~> Using .Find to look for CriteriaA
        Set aCell = rngDB.Find(What:=CriteriaA, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
        '~~> Check if found or not
        If Not aCell Is Nothing Then
            'Set bCell = aCell
            strAdress = aCell.Address
            '~~> Secondary checks
            Do
                If aCell.Offset(, 1).Value2 = CriteriaB And _
                   aCell.Offset(, 2).Value2 = CriteriaC Then '<~~ If match found
                   '~~> Get the origin and the key
                   origin = aCell.Offset(, 6).Value2
                   KeyToFind = aCell.Offset(, 7).Value2
                End If
                '~~> Check the origin
                If origin = "Letters" Then
                    CopyRows "M", KeyToFind, True
                ElseIf origin = "Numbers" Then
                    CopyRows "H", KeyToFind, False
                Else
                    MsgBox "Please check origin. Numbers/Letters not found. Exiting..."
                End If
                 Set aCell = rngDB.FindNext(aCell)
            Loop While aCell.Address <> strAdress
           

        Else
            MsgBox "Criteria A match was not found. Exiting..."
        End If
    End With
End Sub

I've tried this code and it isn't doing anything differently actually. I don't really know what's happening. — rockatheman1, Feb 08 '21 at 13:50
@rockatheman1, I think I know what you intend to do. Just move the code you want to do in the loop. I edited answeer. — Dy.Lee, Feb 08 '21 at 13:54
So I tried this and it does find 1 more match. However there are 7 matches in the table and it's finding 2 now. Perhaps it has to do that the code is divided in 2 parts. The sub and private sub? I edited my main post to show my objective more clearly. — rockatheman1, Feb 08 '21 at 14:05
@rockatheman1, why do you use this code `copyFrom.Copy SomeSheet.Rows(1)`? This will record only one result. — Dy.Lee, Feb 08 '21 at 14:18
When a match is found I would like that match to be copied to the output sheet. So I figured this to be the way to do it. So you're saying it keeps inputting it into the first row? — rockatheman1, Feb 08 '21 at 14:20
Let us [continue this discussion in chat](https://chat.stackoverflow.com/rooms/228418/discussion-between-rockatheman1-and-dy-lee). — rockatheman1, Feb 08 '21 at 14:49

score 0 · Answer 2 · answered Feb 08 '21 at 13:30

Here is a generic FindAll function that you may be able to integrate into the project.

It works in the same way as the standard .Find but returns a range object with all matching cells in the relevant searched, worksheet, range etc. You can then iterate through the returned FindAll range and process the data.

Function FindAll(What, _
    Optional SearchWhat As Variant, _
    Optional LookIn, _
    Optional LookAt, _
    Optional SearchOrder, _
    Optional SearchDirection As XlSearchDirection = xlNext, _
    Optional MatchCase As Boolean = False, _
    Optional MatchByte, _
    Optional SearchFormat) As Range
    
    'LookIn can be xlValues or xlFormulas, _
     LookAt can be xlWhole or xlPart, _
     SearchOrder can be xlByRows or xlByColumns, _
     SearchDirection can be xlNext, xlPrevious, _
     MatchCase, MatchByte, and SearchFormat can be True or False. _
     Before using SearchFormat = True, specify the appropriate settings for the Application.FindFormat _
     object; e.g. Application.FindFormat.NumberFormat = "General;-General;""-"""
     
    Dim SrcRange As Range
    If IsMissing(SearchWhat) Then
        Set SrcRange = ActiveSheet.UsedRange
    ElseIf TypeOf SearchWhat Is Range Then
        Set SrcRange = IIf(SearchWhat.Cells.Count = 1, SearchWhat.Parent.UsedRange, SearchWhat)
    ElseIf TypeOf SearchWhat Is Worksheet Then
        Set SrcRange = SearchWhat.UsedRange
    Else: SrcRange = ActiveSheet.UsedRange
    End If
    If SrcRange Is Nothing Then Exit Function

    'get the first matching cell in the range first
    With SrcRange.Areas(SrcRange.Areas.Count)
        Dim FirstCell As Range: Set FirstCell = .Cells(.Cells.Count)
    End With

    Dim CurrRange As Range: Set CurrRange = SrcRange.Find(What:=What, After:=FirstCell, LookIn:=LookIn, LookAt:=LookAt, _
        SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)
    
    If Not CurrRange Is Nothing Then
        Set FindAll = CurrRange
        Do
            Set CurrRange = SrcRange.Find(What:=What, After:=CurrRange, LookIn:=LookIn, LookAt:=LookAt, _
            SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)
            If CurrRange Is Nothing Then Exit Do
            If Application.Intersect(FindAll, CurrRange) Is Nothing Then
                Set FindAll = Application.Union(FindAll, CurrRange)
            Else: Exit Do
            End If
        Loop
    End If
End Function

Thanks for your comment. I will try to understand this and see if I can implement it like you said. — rockatheman1, Feb 08 '21 at 14:10

score 0 · Answer 3 · edited Feb 09 '21 at 05:40

You are trying to automate in vba they way you would do it in Excel. But vba will work much better for you if you use the memory instead of the sheet. Basically any of your scripts will work much faster if you:

Load your data in memory ( an array, collection, dictionary);
transform your data in memory
write back to your sheet only when all is done;

So based on the above hereunder an alternative version based on what I understood. What this script will do is:

Load your source to memory => Arr
Load the source into a "Dictionary" which is a kind of 1D array with operators that are perfect for doing comparison e.g. ad / remove as you which, check with "if exists", ..
Load the target data to memory
Match the target data with the dictionary values and add them to a new array => Arr2
write all data to the sheet

I added further comments in the code. I understood you want to write the Studentnr to the respective column based on the type but it should anyway put you on the right track to customize further.

    Sub DictMatch()
        Dim Arr, Arr2, j As Long, i As Long, dict As Object
        Set dict = CreateObject("Scripting.Dictionary") 'create dictionary
        With dict 'used because I'm to lazy to retype dict everywhere :)
            .CompareMode = 1 'textcompare
            Arr = Sheets(1).Range("A1").CurrentRegion.Offset(1, 0).Value2 'load source without header
            For j = 1 To UBound(Arr, 1) 'traverse source
                If Not .exists(Arr(j, 15)) Then 'set key if I don't have it yet in dict
                    .Add key:=Arr(j, 15), Item:=Arr(j, 14)
                End If
            Next j
            Arr = Sheets(2).Range("A1").CurrentRegion.Offset(1, 0).Value2 'load target data, as I have what I need in the dict I just reuse the same array. change this if the target could be smaller than the source!
            ReDim Arr2(1 To UBound(Arr), 1 To 2) 'size the target array, just 2 cols
            For j = 1 To UBound(Arr, 1)
                If .exists(Arr(j, 4)) Then 'matching happens here, compare data from target with dictionary
                    i = IIf(.Item(Arr(j, 4)) = "numbers", 1, 2) 'set col to write to
                    Arr2(j, i) = Arr(j, 4) 'write to target array if match
                End If
            Next j
        End With
        With Sheets(2)
            .Range(.Cells(2, 14), .Cells(UBound(Arr2), 15)).Value2 = Arr2 'dump target array to sheet
        End With
    End Sub

best of luck,

Sorry for the late response to your answer! I will try to look into this method. Thank you. — rockatheman1, Feb 09 '21 at 09:08

Code stops after the first match. How do I go about making it repeat?

3 Answers3

Linked