title: Excel VBA to Search for Text in PDF and Extract and Name Pages
body: <p>I have the following code, which looks at each cell in column A of my spreadsheet, searches for the text it finds there in the specified PDF and then extracts the page where it finds the text as a PDF, naming it with the value in the cell of the spreadsheet. The code works but is rather slow, I may need to search for as many as 200 words in a PDF which could be as long as 600 pages. Is there a way to make the code faster? Currently it loops through each cell searches through each page looping through each word until it finds the word in the cell. </p>
  
  <pre><code>    Sub test_with_PDF()
  
      Dim objApp As Object
      Dim objPDDoc As Object
      Dim objjso As Object
      Dim wordsCount As Long
      Dim page As Long
      Dim i As Long
      Dim strData As String
      Dim strFileName As String
      Dim lastrow As Long, c As Range
      Dim PageNos As Integer
      Dim newPDF As Acrobat.CAcroPDDoc
      Dim NewName As String
      Dim Folder As String
      lastrow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
  
      strFileName = selectFile()
      Folder = GetFolder()
  
      Set objApp = CreateObject("AcroExch.App")
      Set objPDDoc = CreateObject("AcroExch.PDDoc")
      'AD.1 open file, if =false file is damage
      If objPDDoc.Open(strFileName) Then
          Set objjso = objPDDoc.GetJSObject
  
   PageNos = 0
   For Each c In Sheets("Sheet1").Range("A2:A" &amp; lastrow)
  
          For page = 0 To objPDDoc.GetNumPages - 1
              wordsCount = objjso.GetPageNumWords(page)
              For i = 0 To wordsCount
  
                  If InStr(1, c.Value, ", ") = 0 Then
  
                      If objjso.getPageNthWord(page, i) = c.Value Then
                          PageNos = PageNos + 1
                          If FileExist(Folder &amp; "\" &amp; c.Offset(0, 4) &amp; ".pdf") Then
  
                                  Set newPDF = CreateObject("AcroExch.pdDoc")
                                  NewName = Folder &amp; "\" &amp; c.Offset(0, 4) &amp; ".pdf"
                                  newPDF.Open (NewName)
                                  newPDF.InsertPages lngPages, objPDDoc, page, 1, 0
                                  newPDF.Save 1, NewName
                                  newPDF.Close
                                  Set newPDF = Nothing
                                  Exit For
                           Else
                                  Set newPDF = CreateObject("AcroExch.PDDoc")
                                  newPDF.Create
                                  NewName = Folder &amp; "\" &amp; c.Offset(0, 4) &amp; ".pdf"
                                  newPDF.InsertPages -1, objPDDoc, page, 1, 0
                                  newPDF.Save 1, NewName
                                  newPDF.Close
                                  Set newPDF = Nothing
                                  Exit For
  
                          End If
                      End If
                  Else
  
                  If objjso.getPageNthWord(page, i) = c.Offset(0, 1).Value Then
                      If objjso.getPageNthWord(page, i + 1) = c.Offset(0, 2).Value Then
                          PageNos = PageNos + 1
                           If FileExist(Folder &amp; "\" &amp; c.Offset(0, 4) &amp; ".pdf") Then
  
                                  Set newPDF = CreateObject("AcroExch.pdDoc")
                                  NewName = Folder &amp; "\" &amp; c.Offset(0, 4) &amp; ".pdf"
                                  newPDF.Open (NewName)
                                  newPDF.InsertPages lngPages, objPDDoc, page, 1, 0
                                  newPDF.Save 1, NewName
                                  newPDF.Close
                                  Set newPDF = Nothing
                                  Exit For
                           Else
                                  Set newPDF = CreateObject("AcroExch.PDDoc")
                                  newPDF.Create
                                  NewName = Folder &amp; "\" &amp; c.Offset(0, 4) &amp; ".pdf"
                                  newPDF.InsertPages -1, objPDDoc, page, 1, 0
                                  newPDF.Save 1, NewName
                                  newPDF.Close
                                  Set newPDF = Nothing
                                  Exit For
  
                          End If
                          Exit For
                      End If
                  End If
              End If
              Next i
          Next page
          c.Offset(0, 3).Value = PageNos
          PageNos = 0
      Next c
      MsgBox "Done"
      Else
          MsgBox "error!"
      End If
  End Sub
  
  Function FileExist(path As String) As Boolean
      If Dir(path) &lt;&gt; vbNullString Then FileExist = True
  End Function
  Function selectFile()
  Dim fd As FileDialog, fileName As String
  
  On Error GoTo ErrorHandler
  
  Set fd = Application.FileDialog(msoFileDialogFilePicker)
  
  fd.AllowMultiSelect = False
  
  If fd.Show = True Then
      If fd.SelectedItems(1) &lt;&gt; vbNullString Then
          fileName = fd.SelectedItems(1)
      End If
  Else
      'Exit code if no file is selected
      End
  End If
  
  'Return Selected FileName
  selectFile = fileName
  
  Set fd = Nothing
  
  Exit Function
  
  ErrorHandler:
  Set fd = Nothing
  MsgBox "Error " &amp; Err &amp; ": " &amp; Error(Err)
  
  End Function
  Function GetFolder() As String
      Dim fldr As FileDialog
      Dim sItem As String
      Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
      With fldr
          .Title = "Select the Folder where you want you new PDFs to go"
          .AllowMultiSelect = False
          .InitialFileName = Application.DefaultFilePath
          If .Show &lt;&gt; -1 Then GoTo NextCode
          sItem = .SelectedItems(1)
      End With
  NextCode:
      GetFolder = sItem
      Set fldr = Nothing
  End Function
  </code></pre>
  
  <p>Many thanks in advance.</p>