Excel VBA - Выбор диапазона файлов для поиска через

Question

Я действительно надеюсь, что кто-то может помочь мне с этим ....

У меня есть макрос на данный момент, что позволяет пользователю ввести номер 8 цифр, а затем код выполняет поиск всех файлов .xls в определенной папке, пока не найдет это число. До сих пор существует 61 файл для поиска, и это число увеличивается с каждым днем! Мой код работает отлично, но это медленный процесс и тот, который пользователь будет делать много раз в день.

Желаемый результат - пользователь вводит дату, т.е. - 2013-10-28, которая является первой частью имени файла, затем введите вторую дату в том же формате, а затем 8-значное число. Затем макрос откроет папку предустановок, найдет первый файл, откроет его и выполнит поиск 8-значного числа. Если номер не найден, я хочу, чтобы макрос переместился к следующему файлу в папке до тех пор, пока не будет найден номер или не достигнет второй папки с определением даты, после чего она остановится.

В худшем случае я хотел бы, чтобы мой существующий макрос функционировал так же, но начинал с самого последнего измененного файла и работал назад, чтобы сократить время работы.

Это то, что я до сих пор (vaCellvalue это 8 значный номер входа пользователем): -

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

Для тех, кто еще там, кто мог бы один день задать этот вопрос здесь ответ, который я придумал в конце концов. Помните, однако, как указано в моем первоначальном вопросе выше, здесь указаны имена файлов - когда поле ввода запрашивает дату создания файла, оно действительно запрашивает у пользователя первую часть имени файла, которая всегда будет Дата.

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