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

Excel VBA - 选择要搜索的文件范围

1 个答案: