Excel VBA zum Suchen nach Text in PDF und Extrahieren und Namen Seiten

Question

Ich habe den folgenden Code, der jede Zelle in Spalte A meiner Tabelle untersucht, sucht nach dem Text findet es dort in der angegebenen PDF und extrahiert dann die Seite Dort findet es den Text als PDF und benennt ihn mit dem Wert in der Zelle der Tabelle. Der Code funktioniert, ist aber eher langsam, ich muss möglicherweise bis zu 200 Wörter in einem PDF suchen, das bis zu 600 Seiten lang sein kann. Gibt es eine Möglichkeit, den Code schneller zu machen? Gegenwärtig durchläuft jede Zelle eine Schleife durch jede Seite, die durch jedes Wort läuft, bis sie das Wort in der Zelle findet.

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" & 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 & "\" & c.Offset(0, 4) & ".pdf") Then 

           Set newPDF = CreateObject("AcroExch.pdDoc") 
           NewName = Folder & "\" & c.Offset(0, 4) & ".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 & "\" & c.Offset(0, 4) & ".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 & "\" & c.Offset(0, 4) & ".pdf") Then 

           Set newPDF = CreateObject("AcroExch.pdDoc") 
           NewName = Folder & "\" & c.Offset(0, 4) & ".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 & "\" & c.Offset(0, 4) & ".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) <> 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) <> 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 " & Err & ": " & 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 <> -1 Then GoTo NextCode 
     sItem = .SelectedItems(1) 
    End With 
NextCode: 
    GetFolder = sItem 
    Set fldr = Nothing 
End Function 

Vielen Dank im Voraus.

Answer 1

Es tut uns leid, eine schnelle, unvollständige Antwort zu posten, aber ich denke, ich kann Sie in eine gute Richtung weisen.

Statt das System die beiden Begriffe hunderte Milliarden Mal nachschlagen zu lassen, dann Hunderte von Milliarden Vergleichen, setzen Sie Ihre Suchbegriffe in ein Array und den Text jeder Seite in einen langen String.Then es nur muss einen Blick nach oben und 200 Vergleiche pro Seite machen.

'Dim your Clipboard functions 
Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long 
Public Declare PtrSafe Function EmptyClipboard Lib "user32"() As Long 
Public Declare PtrSafe Function CloseClipboard Lib "user32"() As Long 

'... 

Dim objData As New MSForms.DataObject 
Dim arrSearch() As String 
Dim strTxt As String 

'... 

'Create array of search terms 
For i = 2 To lastrow 
    arrSearch(i - 2) = Sheets("Sheet1").Cells(1, i) 
Next i 

For page = 0 To objPDDoc.GetNumPages - 1 

    '[Move each page into a new document. You already have that code] 

    'Clear clipboard 
    OpenClipboard (0&) 
    EmptyClipboard 
    CloseClipboard 

    'Copy page to clipboard 
    objApp.MenuItemExecute ("SelectAll") 
    objApp.MenuItemExecute ("Copy") 
    'You can also do this with the JavaScript object: objjso.ExecMenuItem("Item Name") 
    'You may have to insert a waiting function like sleep() here to wait for the action to complete 

    'Put data from clipboard into a string. 
    objData.GetFromClipboard 
    strTxt = objData.GetText 'Now you can search the entire content of the page at once, within memory 

    'Compare each element of the array to the string 
    For i = LBound(arrSearch) To UBound(arrSearch) 
     If InStr(1, strTxt, arrSearch(i)) > 0 Then 
      '[You found a match. Your code here] 
     End If 
    Next i 

Next page 

Dies ist immer noch umständlich, weil Sie jede Seite in einem neuen Dokument öffnen müssen. Wenn es eine gute Möglichkeit gibt, zu bestimmen, auf welcher Seite Sie rein per Text sind (z. B. die Seitennummer am unteren Rand von Seite a, unmittelbar gefolgt von der Kopfzeile oben auf Seite b), dann könnten Sie das Ganze kopieren Text des Dokuments in eine Zeichenfolge und dann anhand der Hinweise aus dem Text entscheiden, welche Seite extrahiert werden soll, sobald Sie eine Übereinstimmung gefunden haben. Das wäre viel schneller, glaube ich.

Answer 2

Sub BatchRenameCS() 

Dim objApp As Object 
Dim objPDDoc As Object 
Dim objjso As Object 
Dim newPDF As Acrobat.CAcroPDDoc 
Dim lastrow2 As Long 
Dim strFileName As String 
Dim Folder As String 
Dim Page As Long 
Dim Cell As Long 
Dim PDFCharacterCount() As Long 
Dim CharacterCount As Long 
Dim i As Integer 
Dim c As Integer 
Dim x As Integer 
Dim strSource As String 
Dim strResult As String 
Dim PDFCharacters As String 
Dim PDFCharacters2 As String 
Dim PDFPasteData() As String 
Dim PasteDataPage As Integer 
Dim LastRow As Long 
Dim NewName As String 
Dim NewNamePageNum As Integer 
Dim Check() 

Sheets("Sheet1").Range("C:D").ClearContents 

strFileName = selectFile() 
Folder = GetFolder() 

'create array with pdf word count 
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 

ReDim PDFCharacterCount(1 To objPDDoc.GetNumPages) As Long 

For Page = 1 To objPDDoc.GetNumPages 
PDFCharacters = "" 
PDFCharacters2 = "" 
    For c = 0 To objjso.GetPageNumWords(Page - 1) 
    PDFCharacters = PDFCharacters & objjso.getPageNthWord(Page - 1, c) 
    Next c 
    For i = 1 To Len(PDFCharacters) 
     Select Case Asc(Mid(PDFCharacters, i, 1)) 
      Case 48 To 57, 65 To 90, 97 To 122: 
      PDFCharacters2 = PDFCharacters2 & (Mid(PDFCharacters, i, 1)) 
      Case Else 
      PDFCharacters2 = PDFCharacters2 & "" 
     End Select 
    Next 
    PDFCharacterCount(Page) = Len(PDFCharacters2) 

Next Page 

lastrow2 = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row 
Page = 1 
ReDim PDFPasteData(1 To objPDDoc.GetNumPages) As String 
For Cell = 1 To lastrow2 
    strResult = "" 
    strSource = Sheets("Sheet2").Cells(Cell, 1).Text 
    PDFPasteData(Page) = PDFPasteData(Page) & " " & strSource 
    For i = 1 To Len(strSource) 
     Select Case Asc(Mid(strSource, i, 1)) 
      Case 48 To 57, 65 To 90, 97 To 122: 
      strResult = strResult & (Mid(strSource, i, 1)) 
      Case Else 
      strResult = strResult & "" 
     End Select 
    Next 

CharacterCount = CharacterCount + Len(strResult) 

If CharacterCount = PDFCharacterCount(Page) Then 
CharacterCount = 0 
Page = Page + 1 
End If 

Next Cell 
ReDim Check(2, objPDDoc.GetNumPages) 
LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row 
For Each LookUpCell In Worksheets("Sheet1").Range("A2:A" & LastRow) 
    For PasteDataPage = 1 To objPDDoc.GetNumPages 
     If InStr(PDFPasteData(PasteDataPage), LookUpCell.Value) Then 
     Check(1, PasteDataPage) = Check(1, PasteDataPage) + 1 
     Check(2, PasteDataPage) = Check(2, PasteDataPage) & LookUpCell.Offset(0, 1).Value & Chr(10) 
           If FileExist(Folder & "\" & LookUpCell.Offset(0, 1) & ".pdf") Then 

             Set newPDF = CreateObject("AcroExch.pdDoc") 
             NewName = Folder & "\" & LookUpCell.Offset(0, 1) & ".pdf" 
             newPDF.Open (NewName) 
             newPDF.InsertPages newPDF.GetNumPages - 1, objPDDoc, PasteDataPage - 1, 1, 0 
             newPDF.Save 1, NewName 
             newPDF.Close 
             Set newPDF = Nothing 
           Else 
             Set newPDF = CreateObject("AcroExch.PDDoc") 
             newPDF.Create 
             NewName = Folder & "\" & LookUpCell.Offset(0, 1) & ".pdf" 
             newPDF.InsertPages -1, objPDDoc, PasteDataPage - 1, 1, 0 
             newPDF.Save 1, NewName 
             newPDF.Close 
             Set newPDF = Nothing 
           End If 
     End If 
    Next PasteDataPage 
Next LookUpCell 
x = 1 
For PasteDataPage = 1 To objPDDoc.GetNumPages 
    If Check(1, PasteDataPage) <> 1 Then 
    Sheets("Sheet1").Cells(x, 3) = PasteDataPage 
    Sheets("Sheet1").Cells(x, 4) = Check(2, PasteDataPage) 
    x = x + 1 
    End If 
Next PasteDataPage 
End If 
MsgBox "Done" 
End Sub 
Function FileExist(path As String) As Boolean 
    If Dir(path) <> 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) <> 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 " & Err & ": " & 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 <> -1 Then GoTo NextCode 
     sItem = .SelectedItems(1) 
    End With 
NextCode: 
    GetFolder = sItem 
    Set fldr = Nothing 

End Function