There are a few ways that you could speed this up. A simple one might be to create a custom sort order for your items, sort your data in that order, and then simply take the first row of data.
Skeleton code would look a bit like this:
Const FIRST_DATA_ROW As Long = 2
Dim wksData As Worksheet, wks As Worksheet
Dim tempRng As Range, sortRng As Range
Dim searchItems As Variant, item As Variant
Dim lastCol As Long, lastRow As Long, rowCount As Long, n As Long
Dim output() As Long
Dim found As Boolean
'HOUSEKEEPING FIRST.
'-------------------
'Define your sheets as required.
Set wksData = ThisWorkbook.Worksheets("Sheet1")
Set wks = ThisWorkbook.Worksheets("Sheet2")
'Define data limits.
With wksData
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Create a temp column to store original sort order.
rowCount = lastRow - FIRST_DATA_ROW + 1
ReDim output(1 To rowCount, 1 To 1)
For n = 1 To rowCount
output(n, 1) = n
Next
Set tempRng = wksData.Cells(FIRST_DATA_ROW, lastCol + 1).Resize(rowCount)
tempRng.Value = output
'SORT THE DATA.
'--------------
'Define the search items in order.
searchItems = Array( _
"efg", _
"hij", _
"klm")
Application.AddCustomList searchItems
'Execute the sort.
With wksData
Set sortRng = .Range( _
.Cells(FIRST_DATA_ROW, "A"), _
.Cells(lastRow, lastCol + 1))
End With
With wksData.Sort
With .SortFields
.Clear
.Add _
Key:=sortRng.Columns("A"), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
CustomOrder:=Join(searchItems, ","), _
DataOption:=xlSortNormal
End With
.SetRange sortRng
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'DATA TRANSFER
'-------------
'Check if first item is in the search list.
For Each item In searchItems
If item = wksData.Cells(FIRST_DATA_ROW, "A").Value2 Then
found = True
Exit For
End If
Next
If Not found Then
'Nothing is found.
MsgBox "No items found."
Else
'Copy data to new sheet.
With wks
lastRow = .Cells(.Rows.Count, "I").End(xlUp).Row
.Cells(lastRow + 1, "I").Value = wksData.Cells(FIRST_DATA_ROW, "A").Value2
End With
End If
'CLEAN UP
'--------
'Unsort data.
With wksData.Sort
With .SortFields
.Clear
.Add _
Key:=tempRng, _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
End With
.SetRange sortRng
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Clear the temp sort order.
tempRng.ClearContents
Another way would be to log each time you hit a match and just look for higher priority items. Once you've reached a top priority item, then end the search. Again, skeleton code could be like this:
Const FIRST_DATA_ROW As Long = 2
Dim wksData As Worksheet, wks As Worksheet
Dim searchItems As Variant, data As Variant
Dim priority As Long, foundIndex As Long, i As Long, j As Long
'Define your sheets as required.
Set wksData = ThisWorkbook.Worksheets("Sheet1")
Set wks = ThisWorkbook.Worksheets("Sheet2")
'Define the search items in order.
searchItems = Array( _
"efg", _
"hij", _
"klm")
'Read the data into an array.
With wksData
data = .Range( _
.Cells(FIRST_DATA_ROW, "A"), _
.Cells(.Rows.Count, "A").End(xlUp)) _
.Value2
End With
'Loop through the data.
priority = -1
foundIndex = -1
For i = 1 To UBound(data, 1)
'Look for a match.
For j = 0 To UBound(searchItems)
If data(i, 1) = searchItems(j) Then
'We have a match, so ...
'Store the values.
foundIndex = i
priority = j
'Remove lower priority search items.
If priority > 0 Then ReDim Preserve searchItems(j - 1)
Exit For
End If
Next
'Stop if we have a top priority match.
If priority = 0 Then Exit For
Next
'Copy the data.
If foundIndex = -1 Then
'Nothing is found.
MsgBox "No items found."
Else
'Copy data to new sheet.
With wks
.Cells(.Rows.Count, "I").End(xlUp).Offset(1).Value = data(foundIndex, 1)
End With
End If
