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$CommonReturns**************"
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