EXCEL VBA – search目录中的每个文件，列出search到的string实例的数量

我试图打开Sheet 2列A中列出的每个文件，search位于Sheet 3单元格B1中的文本string，列出此string出现在Sheet 3中每个特定文件中的实例的数目，然后closures该文件。

我的代码目前工作，但是非常缓慢，有时会产生错误，使一切甚至更慢。 我有成千上万的需要search的文件，速度和性能一样重要。

有没有办法比我已经做的更有效率地完成这个任务？ 奖励积分用于消除任何可能的错误来源。 提前致谢。

Sub FindMe() Dim fle As Range Dim i As Long Dim k As Long Dim line As Long Dim strline As String Dim strsearch As String Dim loc As Range Dim sht As Worksheet Dim lngPos As Long Dim lngCount As Long Dim wdApp As Object Dim wdDoc As Object Dim oRng As Object Dim osld As Object Dim oshp As Object Dim pptApp As Object Dim pptdoc As Object Sheet3.Range("A4:B999999").ClearContents Application.ScreenUpdating = False Application.DisplayAlerts = False If Not IsEmpty(Sheet3.Range("B1").Value) Then strsearch = Sheet3.Range("B1").Value i = 0 k = 4 lngCount = 0 For Each fle In Sheet2.Range("A:A") If InStr(1, fle.Value, ".txt") > 0 Then '.txt extension Open fle.Value For Input As #1 Do While Not EOF(1) Line Input #1, strline lngPos = 1 Do lngPos = InStr(lngPos, strline, strsearch, vbTextCompare) If lngPos > 0 Then lngCount = lngCount + 1 lngPos = lngPos + Len(strsearch) End If Loop Until lngPos = 0 Loop If lngCount <> 0 Then Sheet3.Cells(k, 1).Value = lngCount Sheet3.Cells(k, 2).Value = fle.Value k = k + 1 lngCount = 0 End If Close #1 ElseIf InStr(1, fle.Value, ".xls") > 0 Or InStr(1, fle.Value, ".csv") Then '.xls, .xlsx, .xlsm, .csv extentions Workbooks.Open Filename:=fle.Value, ReadOnly:=True, UpdateLinks:=False For Each sht In ActiveWorkbook.Worksheets With sht Set loc = .Cells.Find(What:=strsearch) If Not loc Is Nothing Then FirstAddress = loc.Address Do i = i + 1 Set loc = .Cells.FindNext(loc) Loop While Not loc Is Nothing And loc.Address <> FirstAddress End If End With Next sht ActiveWorkbook.Close False If i <> 0 Then Sheet3.Cells(k, 1).Value = i Sheet3.Cells(k, 2).Value = fle.Value k = k + 1 i = 0 End If ElseIf InStr(1, fle.Value, ".doc") > 0 Or InStr(1, fle.Value, ".pdf") > 0 Then '.doc, .docx extentions Set wdApp = CreateObject("word.Application") Set wdDoc = wdApp.documents.Open(fle.Value, ReadOnly:=True) Set oRng = wdDoc.Range With oRng.Find Do While .Execute(FindText:=strsearch, MatchCase:=False) i = i + 1 Loop End With wdDoc.Close 0 Set oRng = Nothing Set wdDoc = Nothing Set wdApp = Nothing If i <> 0 Then Sheet3.Cells(k, 1).Value = i Sheet3.Cells(k, 2).Value = fle.Value k = k + 1 i = 0 End If ElseIf InStr(1, fle.Value, ".ppt") > 0 Then '.ppt, .pptx, .pptm extentions Set pptApp = CreateObject("powerpoint.Application") Set pptdoc = pptApp.presentations.Open(fle.Value, ReadOnly:=True) For Each osld In pptdoc.slides For Each oshp In osld.Shapes If oshp.HasTextFrame Then If oshp.TextFrame.HasText Then Set otext = oshp.TextFrame.TextRange Set foundText = otext.Find(findwhat:=strsearch) Do While Not (foundText Is Nothing) lngCount = lngCount + 1 With foundText Set foundText = otext.Find(findwhat:=strsearch, After:=.Start + .Length - 1) End With Loop End If End If Next oshp Next osld pptdoc.Close Set pptdoc = Nothing Set pptApp = Nothing Set otext = Nothing Set foundText = Nothing If lngCount <> 0 Then Sheet3.Cells(k, 1).Value = lngCount Sheet3.Cells(k, 2).Value = fle.Value k = k + 1 lngCount = 0 End If End If Next fle Else: MsgBox "Enter text in cell 'B1' before searching." End If Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub