Speed up macro that extracts text from PDF's in a directory

Jaffey · Mar 17th 2020

I have some code I combined from a couple sources that will open a bunch of pdf's in a directory using Word to extract a sentence of text and place it to excel. It works but is slow because it's opening and closing Word with each iteration. But when I try opening Word before the loop by moving Set WApp = CreateObject("Word.Application") before the start of the loop (and WPapp.Quit after it ends), I get a run time error saying the object is not set. Any advice on how to improve this appreciated.

Code

Option Explicit
Sub LoopPDFsInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim r As Long
Dim WApp As Object
Dim WDoc As Object
Dim WDR As Object
Dim ExR As Range

'  Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual


myPath = "c:\temp\"
myExtension = "*.PDF*"
myFile = Dir(myPath & myExtension)


r = 0


On Error GoTo ResetSettings
Do While myFile <> "" 'Loop through each Excel file in folder
Set ExR = Selection ' current location in Excel Sheet
Set WApp = CreateObject("Word.Application")
'WApp.Visible = True
Set WDoc = WApp.Documents.Open(myPath & myFile)
WApp.Selection.HomeKey Unit:=6
WApp.Selection.Find.ClearFormatting
WApp.Selection.Find.Execute "In the matter of the" 'find key phrase
WApp.Selection.MoveDown Unit:=5, Count:=1
WApp.Selection.HomeKey
WApp.Selection.MoveRight Unit:=3, Count:=1, Extend:=1
Set WDR = WApp.Selection ' copy selected sentence to excel


ExR(1, 1).Offset(r, 0) = WDR ' place below selected cell
r = r + 1


WDoc.Close
WApp.Quit


myFile = Dir 'Get next file name


Loop


Set WApp = Nothing
Set WDoc = Nothing
Set WDR = Nothing


MsgBox "Done!"


ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


End Sub

Display More

ArdusPetus · Mar 17th 2020

Code

Option Explicit

Sub LoopPDFsInFolder()
    Dim wb As Workbook
    Dim myPath As String
    Dim myFile As String
    Dim myExtension As String
    Dim r As Long
    Dim WApp As Object
    Dim WDoc As Object
    Dim WDR As Object
    Dim ExR As Range
    
    ' Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    
    myPath = "c:\users\laurent\documents\perso\"
    myExtension = "*.PDF*"
    myFile = Dir(myPath & myExtension)
    
    Set WApp = CreateObject("Word.Application")
    WApp.Visible = True
    
    r = 0
    
    On Error GoTo ResetSettings
    Do While myFile <> "" 'Loop through each Excel file in folder
        Set ExR = Selection ' current location in Excel Sheet
        Set WDoc = WApp.Documents.Open(myPath & myFile)
        WApp.Selection.HomeKey Unit:=6
        WApp.Selection.Find.ClearFormatting
        WApp.Selection.Find.Execute "In the matter of the" 'find key phrase
        WApp.Selection.MoveDown Unit:=5, Count:=1
        WApp.Selection.HomeKey
        WApp.Selection.MoveRight Unit:=3, Count:=1, Extend:=1
        Set WDR = WApp.Selection ' copy selected sentence to excel
              
        ExR(1, 1).Offset(r, 0) = WDR ' place below selected cell
        r = r + 1
        
        WDoc.Close
        
        myFile = Dir 'Get next file name
    Loop
    
ResetSettings:
    WApp.Quit
    
    Set WApp = Nothing
    Set WDoc = Nothing
    Set WDR = Nothing
    
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Done!"

End Sub

Display More

This should work faster

Cheers,

--

LR

Jaffey · Mar 17th 2020

Thanks Ardus, but that's what was causing my problem. I.e. setting Word before the loop caused the crash but inside the loop it would run. Anyway, I've since figured it out via debugging. It was hanging on WApp.Close. In debug mode ,the Save as window was popping up at that point and not being dealt with so the connection to word app was being broken but this was not apparent when just running it. Once I saved the first file it worked fine thereafter. So, now I can instantiate Word before the loop and all is well. Thank you so much for responding. Now I just need to find the close without saving command in word vba so it doesn't happen again. cheers

Justin Doward · Mar 17th 2020

Hi Jaffey,

Have you tried with:

Code

Application.DisplayAlerts = False

Your Code

Application.DisplayAlerts = True

Not sure if this captures your problem, it would if excel were generating the save as prompt.

Justin

Speed up macro that extracts text from PDF's in a directory

Participate now!

Share