Matching Two Lists of Names using VBA for VLOOKUP

Hi All,

there may be scenarios, in which we may not get unique Id Numbers for Vlookup Formula but we have to use Vlookup. Following is such a situation in which Customer Id numbers are not available but we have to lookup sales amount for each customer.

here, I had done normal sorting from A to Z for both the list and used the following VLOOKUP Formula to get the sales amount.

sorted List in sheet named : "Note"

However, in our practical scenario, we use to get list which is much longer and complicated and normal sorting will not solve the issue and hence I had applied some trick to get a easy solution.

For both the lists I had generated some code using VBA Soudex Function for FIRST TWO wards of each customer name. Later, I used Vlookup formula to match names in both the lists and following is the scenario:

Clearly, from the above screen shot it can be seen that SOUNDEX Function is not very efficient is every instance e.g. Herbs and Herbals , Labs and Lab, Pvt and Private etc.

Hence, I created a revised scenario:

in the above sheet, I had generated Soundex Code based on which only the first phrase e.g Rashmi generated a code R250. Now I wanted to create a VBA Custom Function which will accept a Range Argument from Column A and search the same in Column E and will pass the matches (Name of the companies in Col F ) in an Array (named VAR). If the array is plotted in Excel sheet it will look like this:

and secondly, I used some VBA Code to split an item corresponding to the Range Argument in Col A i.e. Cell "B9" ( "Rashmi Metalics Ltd ) corresponding to the Range Argument R250 in Col A. Here the resultant Array named VarOne and if the same is plotted in Excel sheet it will look like this :

Here, the elements of VAR Array will be split based on space ( " " ) and the resultant elements will be transferred to another Array named "VarTwo". The Elements of VarTwo Array should be look like : "Rashmi", "Metals", "Ltd", "Rashmi", "Cement" "Ltd".

Now, the second Element of VarOne Array ( i.e Metals) will be matched with the elements of "VarTwo" Array using LIKE Operator of VBA and whenever it finds a match ( e.g. Metals is LIKE Metalics ) the position of the element of VAR Array ( Rashmi Metals Ltd ) in Range ("F2: F16") will be returned to the custom Function.

The Comparison will go on until "VarOne" Array element named "Ltd" is reached.

In India, LTD and Limited, Pvt and Private are synonymous and hence the comparison will go on until such expressions are fond.

However, the VBA Code is given below in Sub Procedure form as I was unable to create the Function Procedure for the same. The Code certainly have some errors and due to which it is not producing the desired result. Pls help to get the correct code.

Sub FindText() 

Dim Rng As Range 

Dim Var() As Variant 

Dim VarOne As Variant 

Dim VarTwo As Variant 

Dim i As Long 

Dim j As Long 

Dim l As Long 

Dim Adr As String 

Dim MyRng As Range 

Dim sht As Worksheet 

Set Rng = Application.InputBox("Select Text", Type:=8) 

Set sht = ActiveSheet  
Set MyRng = sht.Range("E:E").Find(what:=Rng.Value, LookIn:=xlValues, Lookat:=xlWhole) 

If Not MyRng Is Nothing Then 

    Adr = MyRng.Address 

    Do 

        i = i + 1 

        ReDim Preserve Var(1 To i) 

        Var(i) = MyRng.Offset(0, 1) 

        Set MyRng = sht.Range("E:E").Find(what:=Rng.Value, After:=MyRng, _ 

                    LookIn:=xlValues, Lookat:=xlWhole) 

    Loop Until MyRng.Address = Adr 

End If 

VarOne = Split(Rng.Offset(0, 1).Value, " ") 

'Attempt to make a comparison of VarOne Array 

'With the elements of VarTwo Array 

'VarTwo Array getting generated in Loop 

'Help is required to get the code Corrected 

'The Comparison will go on until "LTD", "Limited", "Pvt", "Private" Words 

'are reached. 

For j = 1 To UBound(Var) 

VarTwo = Split(Var(j), " ") 

    For l = 1 To UBound(VarOne) 

    If VarOne(l) Like VarTwo(j) & "*" Then 

    p = sht.Range("F2:F16").Find(what:=Var(j), _ 

    Lookat:=xlWhole).Row 

    End If 

    Next l 

Next j
End Sub