Help optimizing function to find value, do comparison, add to count

[VBAOverkill]

The function sets to take a range of values specified by the user by entering =newvalue(range) in a cell where the range is any range identified by the user. For our example, the range is a list of contract numbers.

The code then loops through each non-empty value in the range, and looks up each value on a separate tab titled "Database". Once the contract number is found on the "Database" tab, the adjacent cell to the right which contains an expiration date is stored as a variable for comparison. Each value in the loop is compared to a specified date, in this case it is 9/1/17, and if the value is less than or equal to the date a counter is incremented. If a non-empty cell is encountered in the range, the function ends.

For my use, I have a list of sheet names in Column A on a tab titled "Index". The workbook also includes a thousand tabs for individual customers with each of their series of contract numbers listed in Column A. A sample dynamic formula to run the function would be entering the following formula on the "Index" page in Column B and auto-fill for all sheet names listed in Column A. =newvalue(INDIRECT("'"&A2&"'!"&"A2:A2000")). This specifies to lookup the sheet name in Column A, and use A2:A2000 as the default range to run the function below. This range was chosen as the lookup values on all sheets would never exceed 2000 rows, but are variable from 1 row to 2000.

The code works well, and returns the values, but the problem exists when trying to use this formula which encounters a sheet containing a large number of rows (e.g 400, 800, 1500, etc.). It takes significant resources to calculate the value.

How can I optimize this code to return a quicker result?

Function newvalue(xRg As Range) As String

Dim xCell As Range
Dim newstatus As Date
Dim match As Range
Dim ws As Worksheet

'set x default to 0

x = 0

'identify tab to retrieve new data value

Set ws = ThisWorkbook.Sheets("Database")

'loop for each value in range identified in function range

For Each xCell In xRg

     'if an empty cell is encountered, end function and return count

     If xCell = Empty Then

          newvalue = x
          Exit Function

     End If

     'for each non-empty cell in the range, search for the value and return
     'the adjacent cell to the right

     Set match = ws.Cells.Find(xCell)
     newstatus = match.Offset(, 1).Value

     'if the new date value found is less than or equal to comparison value
     'then add 1 to count and return value

     If newstatus <= CDate("9/1/2017") Then

          x = x + 1
          newvalue = x

     End If
    
Next

 

[pbornemeier]

This site discusses code optimization: https://msdn.microsoft.com/en-us/library/office/ff726673(v=office.14).aspx

Have you tried consolidating all 1000 tabs to a single tab prior to starting each search and searching on that single tab? With a large number of lookups that may be a faster option.