Excel VBA - Selecting a range of files to search through - file

Question

I really hope someone can help me with this....
I have a macro at the moment that allows the user to input an 8 digit number and then the code searchs all .xls files in a specific folder until it finds that number. So far there are 61 files to search through and that number is getting bigger every day! My code works fine but it is a slow process and one that the user will be doing many times a day.
Desired outcome - the user will input a date, ie - 2013-10-28, which is the first part of a file name, then input a second date in the same format and then an 8 digit number. The macro will then open a preset folder, find the first file, open it and search for the 8 digit number. If the number is not found i want the macro to move to the next file in the folder until either the number is found or it reaches the second date defined folder at which point it will stop.
Worst case i'd like my existing macro to function the same but start with the most recently modified file and work backwards to cut down the running time.
This is what i have so far (vaCellvalue is the 8 digit number input by the user):-
Sub UKSearch()
Dim FSO As Object 'FileSystemObject
Set FSO = CreateObject("scripting.filesystemobject")
Dim Directory As String
Dim FileName As String
Dim varCellvalue As Long
Application.ScreenUpdating = False
MsgBox ("This may take a few minutes")
'value to be searched
varCellvalue = Range("D13").Value
'Change the directory below as needed
Directory = "\\**********\shared$\******\*******\********\"
If Right(Directory, 1) <> "\" Then
Directory = Directory & "\"
End If
'Search for all files in the directory with an xls* file type.
FileName = Dir(Directory & "*.xls*")
'Opens, searches through and closes each file
Do While FileName <> ""
OpenFile = Directory & FileName
Workbooks.Open (OpenFile)
Workbooks(FileName).Activate
'Count through all the rows looking for the required number
ActiveWorkbook.Sheets("UK Scan Sheet").Activate
LastRow = Range("B65536").End(xlUp).Row
intRowCount = LastRow
Range("B1").Select
For i = 1 To intRowCount
'If the required number is found then select it and stop the search
If ActiveCell.Value = varCellvalue Then
GoTo Finish
Else
End If
ActiveCell.Offset(1, 0).Select
Next i
Workbooks(FileName).Close
FileName = Dir
OpenFile = ""
Loop
Finish:
Application.ScreenUpdating = False
End Sub`

Answer 1

For anyone else out there who might one day ask this question here is the answer that i came up with in the end. Please be aware however as stated in my original question above, the dates involved here are file names - when the input box asks for a file creation date it is really asking the user for the first part of a file name that happens to always be a date.
Sub OpenByCreationDate()
Dim appShell As Object
Dim FileName As Variant
Dim FilePath As Variant
Dim oFolder As Object
Dim oFolderItem As Object
Dim TestDate As Variant
Dim IntCount As Variant
FolderPath = "\\cor-***-****\shared$\Common\Returns\**************\"
FileName = "*.xls*"
EnterDate:
TestDate = inputbox("Enter the file creation date below.")
If Not IsDate(TestDate) Then
MsgBox "The Date you entered is not valid." & vbCrLf _
& "Please enter the date again."
GoTo EnterDate
End If
SearchValue = inputbox("Enter the consignment number below.")
IntCount = 0
Set appShell = CreateObject("Shell.Application")
Set oFolder = appShell.Namespace(FolderPath)
For Each oFolderItem In oFolder.Items
If IntCount > 0 Then
TestDate = Left(oFolderItem.Name, 10)
Else
End If
If oFolderItem.Name Like TestDate & FileName Then
Workbooks.Open oFolderItem.Path
ActiveWorkbook.Sheets("UK Scan Sheet").Activate
LastRow = Range("B65536").End(xlUp).Row
intRowCount = LastRow
Range("B1").Select
For i = 1 To intRowCount
'If the required number is found then select it and stop the search
If ActiveCell.Value = SearchValue Then
ActiveCell.Select
MsgBox "Consignment number found."
GoTo Finish
Else
End If
ActiveCell.Offset(1, 0).Select
Next i
ActiveWorkbook.Close
IntCount = IntCount + 1
If IntCount = 10 Then
MsgBox "Consignment number could not be found, please try a different date."
Exit Sub
Else
End If
End If
Next oFolderItem
Finish:
End Sub