EXCEL VBA - 搜索目录中的每个文件，列出搜索字符串

Question

我正在尝试打开Sheet2列A中列出的每个文件，搜索位于Sheet3 Cell B1中的文本字符串，列出此字符串出现在Sheet3中每个特定文件中的实例数，然后关闭该文件。 / p>

我的代码目前正在运行，但速度很慢，有时会产生错误，导致一切变得更慢。我有成千上万的文件需要搜索，所以速度和性能一样重要。

有没有办法比我现在做的更有效地完成这项任务？用于删除任何可能的错误来源的奖励积分。提前谢谢。

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