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 (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