To Find Partial Matches in Array in excel vba-CodePudding

I have an excel sheet containing multiple names in a column (about 2000 rows) in a column The Name can be of multiple words (First Name, Middle Name, Last Name etc) seperated by space character. I have to take that name and loop thorough all the sheets (containing 1000 rows) and find that name on it. But issue is that the Name on the other sheet may in different format (Last Name, Middle Name, First Name) or (First Name, Last Name only). Kindly suggest me best way to find the address of the cell where it is found. What i tried : I used array split function to split name into multiple strings and then used findall function to find all matching addresses and put it into output sheet. Then i used conditional formatting to find duplicate addresses. This works well with smaller data set (100s of rows) but with the larger data set it takes more than 40 minutes. I am out of thoughts now. Kindly guide me how to proceed.

Findall function is normal except the fact that as soon as an address is found it is output on sheet (Mbanksh) if date on that sheet matches BEntryDate. All sheets have different columns where names are placed but all names are in a single column.

Function FindAll(NameArrPart As Variant) As String
On Error Resume Next
Dim sh As Worksheet
Dim Loc As Range
Dim foundCell As Range    'single cell
Dim foundCells As Range   'all found cells
Dim celladdress As String 'just used so you know when you've found everything
Dim x As Long

x = 0
For Each sh In ThisWorkbook.Worksheets
    If sh.Name <> "Matrix" And sh.Name <> "Matrix Modified" Then
        With sh.UsedRange
            Set foundCell = .Cells.Find(What:=NameArrPart)
            If Not foundCell Is Nothing Then
                'find all other matching cells with FindNext
                celladdress = foundCell.Address
                Set foundCells = foundCell
                Do
                    Set foundCell = .FindNext(foundCell)
                    
                    Select Case foundCells.Parent.Name
                    
                    Case "American"
                    If foundCells.Offset(0, -1).Value = BEntryDate Then
                        MBanksh.Cells(1, 27).Offset(x, ArrayIndex).Value = (foundCells.Parent.Name & "!" & foundCells.Address)
                        x = x   1
                    End If
                    
                    Case "National General"
                    If foundCells.Offset(0, 2).Value = BEntryDate Then
                        MBanksh.Cells(1, 27).Offset(x, ArrayIndex).Value = (foundCells.Parent.Name & "!" & foundCells.Address)
                        x = x   1
                    End If
                    
                    Case "Freedom"
                    If foundCells.Offset(0, 3).Value = BEntryDate Then
                        MBanksh.Cells(1, 27).Offset(x, ArrayIndex).Value = (foundCells.Parent.Name & "!" & foundCells.Address)
                        x = x   1
                    End If
                    
                    Case "Bristol West"
                    If foundCells.Offset(0, 1).Value = BEntryDate Then
                        MBanksh.Cells(1, 27).Offset(x, ArrayIndex).Value = (foundCells.Parent.Name & "!" & foundCells.Address)
                        x = x   1
                    End If
                    
                    Case "Capital"
                    If foundCells.Offset(0, 1).Value = BEntryDate Then
                        MBanksh.Cells(1, 27).Offset(x, ArrayIndex).Value = (foundCells.Parent.Name & "!" & foundCells.Address)
                        x = x   1
                    End If
                    
                    Case "Omni"
                    If foundCells.Offset(0, 1).Value = BEntryDate Then
                        MBanksh.Cells(1, 27).Offset(x, ArrayIndex).Value = (foundCells.Parent.Name & "!" & foundCells.Address)
                        x = x   1
                    End If
                    
                    Case "Kemper"
                    If foundCells.Offset(0, 2).Value = BEntryDate Then
                        MBanksh.Cells(1, 27).Offset(x, ArrayIndex).Value = (foundCells.Parent.Name & "!" & foundCells.Address)
                        x = x   1
                    End If
                    
                    End Select
                    
                    If Not foundCell Is Nothing Then
                        Set foundCells = Union(foundCells, foundCell) 'combine found cells
                    Else: Exit Do
                    End If
                Loop While celladdress <> foundCell.Address
            End If
        End With
    End If
Next
End Function`

Then i go to another function to check conditinal formatting.

`Sub CFDetection()
Dim c As Range
Dim ResultArr As Integer
ResultArr = 0
For Each c In MBanksh.Range("AB1:AB5")
        If c.DisplayFormat.Interior.Color <> 16777215 Then
            ResultArr = ResultArr   1
            ResultAdd = c.Value
            Exit For
        End If
Next c
For Each c In MBanksh.Range("AC1:AC5")
        If c.DisplayFormat.Interior.Color <> 16777215 Then
            ResultArr = ResultArr   1
            ResultAdd = c.Value
            Exit For
        End If
Next c
For Each c In MBanksh.Range("AD1:AD5")
        If c.DisplayFormat.Interior.Color <> 16777215 Then
            ResultArr = ResultArr   1
            ResultAdd = c.Value
            Exit For
        End If
Next c
For Each c In MBanksh.Range("AE1:AE5")
        If c.DisplayFormat.Interior.Color <> 16777215 Then
            ResultArr = ResultArr   1
            ResultAdd = c.Value
            Exit For
        End If
Next c
For Each c In MBanksh.Range("AF1:AF5")
        If c.DisplayFormat.Interior.Color <> 16777215 Then
            ResultArr = ResultArr   1
            ResultAdd = c.Value
            Exit For
        End If
Next c

If ResultArr >= 2 Then
    MBanksh.Hyperlinks.Add MBanksh.Range("N" & i), "", ResultAdd, , ResultAdd
End If

End Sub`

CodePudding user response：

(I don't have enough rep to add a comment) Have you considered not using a loop in the first place? If you used an the results show that the cells containing the 3 names in any order have been identified

CodePudding user response：

Why not to iterate over possible name patterns? Let me know if this code works for you and how long it takes to solve the problem.

Function GetNameEntries(ByVal Name As String, Patterns, DataSheets) As Collection
' Return addresses of cells, where Name can be found in any acceptable pattern.
' Name = Join(Array(FirstName, MiddleName, LastName))
' Patterns is a set of arrays with acceptable sequences of the name parts,
' e.g. Pattern = Array(2, 0) means "LastName FirstName" is one of the name forms to search for.
Dim NameParts As Variant
Dim NameVariation As String
Dim NextFound As Range
Dim FirstFoundAddress As String
Dim FoundEntries As New Collection
Dim sh As Worksheet
Dim Pattern As Variant
    On Error Resume Next
    NameParts = Split(Name)
    For Each Pattern In Patterns
        NameVariation = JoinByPattern(NameParts, Pattern)
        For Each sh In DataSheets
            Set NextFound = sh.Cells.Find(NameVariation, LookAt:=xlWhole)
            If Not NextFound Is Nothing Then
                FirstFoundAddress = NextFound.Address(external:=True)
                FoundEntries.Add FirstFoundAddress
                Set NextFound = sh.Cells.FindNext(NextFound)
                Do While NextFound.Address(external:=True) <> FirstFoundAddress
                    FoundEntries.Add NextFound.Address(external:=True)
                    Set NextFound = sh.Cells.FindNext(NextFound)
                Loop
            End If
        Next sh
    Next Pattern
    Set GetNameEntries = FoundEntries
End Function

Function NamePatterns() As Collection
' Return a collection of possible name patterns.
Const FirstName = 0
Const MiddleName = 1
Const LastName = 2
    Set NamePatterns = New Collection
    With NamePatterns
        .Add Array(FirstName, MiddleName, LastName)
        .Add Array(LastName, FirstName, MiddleName)
        .Add Array(FirstName, LastName)
        ' ... (any other patterns)
    End With
End Function

Function JoinByPattern(Source As Variant, Pattern As Variant) As String
' Join strings from the Source array according indexes, which are passed in the Pattern array.
' Example:
'   Source = Array("Anthony", "Steward", "Cunnings")
'   Pattern = Array(2, 0)
'   JoinByPattern(Source, Pattern) = "Cunnings Anthony"
Dim Result() As String
Dim index%
    ReDim Result(LBound(Pattern) To UBound(Pattern))
    For index = LBound(Pattern) To UBound(Pattern)
        Result(index) = Source(Pattern(index))
    Next index
    JoinByPattern = Join(Result)
End Function

Function DataSheets(ExcludeNamePattern As String) As Collection
Dim sh As Worksheet
    Set DataSheets = New Collection
    For Each sh In ThisWorkbook.Worksheets
        If Not sh.Name Like ExcludeNamePattern Then DataSheets.Add sh
    Next sh
End Function

Sub Test()
Const SheetsToExclude = "Matrix*"   ' a data sheet with names in a form "Firstname Middlename Lastname"
Const Names = "Matrix!A1:A3"        ' a range address with names to search for
Dim Name As Range
Dim Patterns As Collection
Dim Sheets As Collection
Dim Entry As Variant
    Set Patterns = NamePatterns
    Set Sheets = DataSheets(SheetsToExclude)
    For Each Name In Range(Names)
        Name.Select
        For Each Entry In GetNameEntries(Name, Patterns, Sheets)
            Selection.Offset(0, 1).Select
            Selection = Entry
        Next Entry
    Next Name
End Sub