VBA code for lookup table

[AlanB]

Hi

I am struggling to convert a formula I have created in excel into a macro and I am looking for some help. Any help would be appreciated.

Apologies for my description below but I am finding hard to get into words what I am trying to achieve.

In column A of sheet 1 I have a large amount of text data. E.g University/ Company names - Westminster University, University of Westminster, University of Westminster London, BT PLC, BT inc, BT Inc., BT, etc etc

In column A of sheet 2 I have a table containing a larger list of similar data found in sheet 1.
Parallel to that in column B of sheet 2 I have the text that I would like to convert the text in column A of sheet 1 to if there is an perfect exact match to make everything uniform when I run the script.
In fact rather than converting the text I would like column A of sheet 1 to remain the same and the new information to be added to column B. At the same time in column C I would like the data in column C of the sheet 2 look up table to be inputted also.

Example of the sheet two lookup table.

Column A Column B Column C
Westminster University Westminster University University
University of Westminster Westminster University University
University of Westminster London Westminster University University
BT PLC BT Company
BT BT Company
BT Inc BT Company
BT inc. BT Company


I would need the ability to constantly add the table in sheet two to improve the results.

I had trouble with my excel formula creating an exact match. The lookup in some instances produced bad results - For example HeidelbergInstitute returned the result Berg as I had a company with that name in the look up table of sheet 2. If the company / university is not found then I would like N/A returned.

Many thanks for your help.
A

[offthelip]

try this:

Sub movdat()


Dim inarr As Variant
Dim thisarr as variant
With Worksheets("Sheet2")
    lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    inarr = Range(.Cells(1, 1), .Cells(lastrow, 6))
End With
With Worksheets("Sheet1")
    lastrow1 = .Cells(Rows.Count, "A").End(xlUp).Row
    thisarr = Range(.Cells(1, 1), .Cells(lastrow1, 6))


For i = 1 To lastrow1
  For j = 1 To lastrow
   If thisarr(i, 1) = inarr(j, 1) And thisarr(i, 1) <> "" Then
      .Cells(i, 2) = inarr(j, 2)
      .Cells(i, 3) = inarr(j, 3)
   End If
  Next j
Next i
End With


End Sub

[mdmackillop]

You can post a sample workbook using Go Advanced/Manage Attachments

[SamT]

See if this works for you

Option Explicit

'This is a specialty Procedure and requires some preparation on your part before runnung it.
'It is designed to add a Column of Standardised Names and a column of Designators to sheet 1
'  from the three colums, Common Names, Standard Names, and Designators on sheet2. (Columns
'  "A," "B," and "C."
'
'In the interest of Speed:
'It is required that you first Sort Sheet1 such that Common Names that have not been previously
'  processed are at the bottom of the list. IOW, Empty Cells in Columns "B" and "C" are at
'  the bottom. This insures that we do not have to loop thru the entirety of Column "A" on
'  Sheet1 every time.
'
'Also in the quest for speed, when you add new items to sheet2, you should leave a blank row
'  between the new items and the old.After processing these additional items, remove the
'  blank Row.
'  NOTE: If you added new items to sheet1 at the same time, omit the blank Row so that
'  the new items on sheet 1 are compared to the entire list on sheet2.

Sub Add_StandardNames_and_Designators()
Dim Cel As Range
Dim Found As Range
Dim Sht1List As Range
Dim Sht2List As Range

  With Sheets("Sheet1")
    Set Sht1List = Range(.Cells(Rows.Count, "A").End(xlUp), _
                         .Cells(Rows.Count, "B").End(xlUp).Offset(1, -1))
  End With
  
  With Sheets("Sheet2")
    Set Sht2List = Cells(Rows.Count, "A").End(xlUp)
    Set Sht2List = Range(Sht2List, Sht2List.End(xlUp))
  End With
  
  For Each Cel In Sht1List
    Set Found = Sht2List.Find(Cel)
    If Not Found Is Nothing Then Cel.Offset(, 1).Resize(, 2) = Found.Offset(, 1).Resize(, 2)
  Next Cel
    
End Sub

[AlanB]

Offthelip - This worked very well - thank you for your help.

SamT - I am unsure what happened but I could not get anything to work at all? If you have any suggestions please let me know - but the suggestion by Offthelip worked well. Your method to reduce time and only work on the new data does sound beneficiary.

Alan

[AlanB]

I am afraid I was unable to make this work. I could not get any results at all?

[SamT]

Alan,

Does the logic in my suggestion make sense when compared to your workbook?

Did you place that code in a standard Module?

Make these changes and see what is (not) going on

    With Sheets("Sheet1") 
        Set Sht1List = Range(.Cells(Rows.Count, "A").End(xlUp), _ 
        .Cells(Rows.Count, "B").End(xlUp).Offset(1, -1)) 
    End With 
Msgbox "Sht1List Address:= " & Sht1List.Address '<-------------
     
    With Sheets("Sheet2") 
        Set Sht2List = Cells(Rows.Count, "A").End(xlUp) 
        Set Sht2List = Range(Sht2List, Sht2List.End(xlUp)) 
    End With 
Msgbox "Sht2List Address:= " & Sht2List.Address '<-------------
     
    For Each Cel In Sht1List 
MsgBox "Working on Sheet1 Row #" & Cel.Row
        Set Found = Sht2List.Find(Cel) 
        If Not Found Is Nothing Then 
MsgBox "Found a Match at Sheet2 Rpw $" & Found.Row  '<-------------
Cel.Offset(, 1).Resize(, 2) = Found.Offset(, 1).Resize(, 2)  '<-------------
End If  '<-------------
    Next Cel

[offthelip]

If you want the routine to work really fast, the way to do that is to minimise the number of accesses to the spreadsheet, this can eaily be done by modifying my code as below. I have also done an "exit for" to exit the inner loop once a match is found.
Also I did some tests on how using variant arrays compared with setting range object, and in terms of time variant arrays wins easily, see this thread:
http://www.vbaexpress.com/forum/showthread.php?60306-loading-a-variant-array

Unless you have tens of thousands of rows I think you will find doing all of the rows everytime will not give any noticeable delay.

Sub movdat()
     
     
    Dim inarr As Variant
    Dim thisarr As Variant
    With Worksheets("Sheet2")
        lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
        inarr = Range(.Cells(1, 1), .Cells(lastrow, 6))
    End With
    With Worksheets("Sheet1")
        lastrow1 = .Cells(Rows.Count, "A").End(xlUp).Row
        thisarr = Range(.Cells(1, 1), .Cells(lastrow1, 6))
        outarr = Range(.Cells(1, 2), .Cells(lastrow1, 3))
         
        For i = 1 To lastrow1
            For j = 1 To lastrow
                If thisarr(i, 1) = inarr(j, 1) And thisarr(i, 1) <> "" Then
                    outarr(i, 1) = inarr(j, 2)
                    outarr(i, 2) = inarr(j, 3)
                    Exit For
                End If
            Next j
        Next i
         Range(.Cells(1, 2), .Cells(lastrow1, 3)) = outarr
    
    End With
     
     
End Sub

note: not tested