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