Searching for multiple names and variants

Hello Chris,

Do you want to replace the variant name in column "C" (Description and Memo) with the proper forename and surname? Forename in this case is one or more given names like "Julian David".

Hello Chris,

The macro below has been added to the attached workbook. There are 2 additional sheets along with you original data. The sheet "Expense Summary" is where the macro outputs the person's forename and surname along with the cost code, date and amount. The third sheet "Names List" contains the proper name, forename and surname, along with the possible variations in the columns to the right.

Currently, there are five additional variations allowed. If you need more, add a label in row 1 for the new column. The macro uses the column headers to automatically size the dictionary.

Option Explicit

' Thread:  http://www.excelforum.com/excel-programming/820336-searching-for-multiple-names-and-variants.html
' Poster:  CFlack8472
' Written: March 19, 2012
' Author:  Leith Ross

Sub ExpenseSummary()

    Dim Cell As Range
    Dim Dict As Object
    Dim DstWks As Worksheet
    Dim Found As Boolean
    Dim Item As Variant
    Dim Key As Variant
    Dim N As Long
    Dim NameData As Variant
    Dim R As Long
    Dim Rng As Range
    Dim RngEnd As Range
    Dim SrcWks As Worksheet
    
        Set SrcWks = Sheet1
        
        Set DstWks = Sheet2
        
        NameData = Sheet3.UsedRange.Offset(1, 0).Resize(Sheet3.UsedRange.Rows.Count - 1).Value
        
        Set Dict = CreateObject("Scripting.Dictionary")
        Dict.CompareMode = vbTextCompare
        
            For Each Item In NameData
                If R = UBound(NameData, 1) Then R = 1 Else R = R + 1
                If Item <> "" Then
                    Key = Trim(Item)
                    If Not Dict.Exists(Key) Then
                        Dict.Add Key, R + 1
                    End If
                End If
            Next Item
            
            Set Rng = SrcWks.Range("C2")
            Set RngEnd = SrcWks.Cells(Rows.Count, "C").End(xlUp)
            Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, SrcWks.Range(Rng, RngEnd))
            
            Application.ScreenUpdating = False
            
            DstWks.UsedRange.Offset(1, 0).ClearContents
            N = 2
            
            For Each Cell In Rng
                For Each Key In Dict.Keys
                    R = Dict(Key)
                    If InStr(1, Cell.Value, Key, vbTextCompare) Then
                        Found = True
                        DstWks.Cells(N, "A") = Sheet3.Cells(R, "A").Value
                        DstWks.Cells(N, "B") = Sheet3.Cells(R, "B").Value
                        DstWks.Cells(N, "C").Resize(1, 2) = SrcWks.Cells(Cell.Row, "A").Resize(1, 2).Value
                        DstWks.Cells(N, "E") = SrcWks.Cells(Cell.Row, "D").Value
                    End If
                Next Key
                If Found Then N = N + 1: Found = False
            Next Cell
            
            Application.ScreenUpdating = True
            
End Sub

Hello Chris,

You're welcome. If you need anything changed, let me know.