Code works but needs refinement. Convert PDF to word. Clean up word doc. Convert word to Excel. Search Excel. Then Output data to spreadsheet

Question

My job has us write reports on a special system that then outputs the reports as a PDF.

I've taken these PDFs and converted them into word documents to make them easily manipulatable.

Then i've taken the word document and cleaned it up a bit then converted it finally into an Excel sheet.

I then search that sheet for specific phrases found in the PDF then output the results in columns.

The goal is to create a sheet with all the data points collected in a format to view for tracking and trending.

I've written the code so that it "WORKS" but it's long and ugly and if anything changes in the PDFs it throws off the whole thing.

I'm hoping for some help in refining what I have to make cleaner and work better.

Right now it takes 35 seconds to execute the code which is 10x faster than doing it by hand but still too slow.

It would be nice to have a table at the top of the code that I can quickly change the data points i'm searching for without having to scan through the code (variables?)

Please help!

Code below!

   Sub AN()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim intChoice As Integer
Dim strPath As String
Dim objWord As Object
Set objWord = CreateObject("Word.Application")

objWord.Visible = False

Dim fDialog As FileDialog, result As Integer, it As Variant
Set fDialog = Application.FileDialog(msoFileDialogOpen)
    
'Optional: FileDialog properties
fDialog.Title = "Select a file"
fDialog.InitialFileName = "\\rl.gov\data\userdata\H2138579\Tracking and trending program\pdf\AN"
    


Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'FileDialog.InitialFileName = "\\hanford\data\sitedata\tfo-rcw-routines\Templates\Auto fill T&T project\ATT V3"

intChoice = Application.FileDialog(msoFileDialogOpen).Show
'if the user selects a file
If intChoice <> 0 Then
    'get the path selected
    strPath = Application.FileDialog( _
        msoFileDialogOpen).SelectedItems(1)
    'opens the document
    objWord.Documents.Open (strPath)

End If
'file path for Program spread sheet (ATT V3.XLSM)
   'ChangeFileOpenDirectory "\\rl.gov\data\userdata\H2138579\Tracking and trending program\TSCR.xlsm\"
   

'File path for Auto Converted Survey word document
    objWord.ActiveDocument.SaveAs2 Filename:="\\rl.gov\data\userdata\H2138579\Tracking and trending program\converted\AutoConvertedSurvey.docx", _
        FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
        AddToRecentFiles:=False, WritePassword:="", ReadOnlyRecommended:=False, _
        EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
        :=False, SaveAsAOCELetter:=False, CompatibilityMode:=15
        
'Close/Save/Quit Word document
      objWord.Documents.Close SaveChanges:=wdSaveChanges
      objWord.Quit
        'appwd.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges



Dim xObjDoc As Object

Dim xWdApp As Object

Dim xWdName As Variant

Dim xWb As Workbook

Dim xWs As Worksheet

Dim xName As String

Dim xPC, xRPP



    ChDir "\\rl.gov\data\userdata\H2138579\Tracking and trending program\Converted\"
xWdName = "\\rl.gov\data\userdata\H2138579\Tracking and trending program\Converted\AutoConvertedSurvey.DOCX"

If xWdName = False Then Exit Sub



Set xWb = Application.ActiveWorkbook

Set xWs = xWb.Worksheets.Add

Set xWdApp = CreateObject("Word.Application")

xWdApp.ScreenUpdating = False

xWdApp.DisplayAlerts = False

Set xObjDoc = xWdApp.Documents.Open(Filename:=xWdName, ReadOnly:=True)

xObjDoc.Activate

xPC = xObjDoc.Paragraphs.Count

Set xRPP = xObjDoc.Range(Start:=xObjDoc.Paragraphs(1).Range.Start, End:=xObjDoc.Paragraphs(xPC).Range.End)

xRPP.Select

On Error Resume Next

xWdApp.Selection.Copy

xName = xObjDoc.Name

xName = Replace(xName, ":", "_")

xName = Replace(xName, "\", "_")

xName = Replace(xName, "/", "_")

xName = Replace(xName, "?", "_")

xName = Replace(xName, "*", "_")

xName = Replace(xName, "[", "_")

xName = Replace(xName, "]", "_")


If Len(xName) > 31 Then

    xName = Left(xName, 31)

End If


xWs.Name = xName

xWs.Range("A1").Select
xWs.Paste

xObjDoc.Close

Set xObjDoc = Nothing



xWdApp.Quit (wdDoNotSaveChanges)

Sheets.Add
ActiveSheet.Name = "Stage"

    Sheets("AutoConvertedSurvey.docx").Select
    Range("A6:N37").Select
    Selection.ClearContents
    Sheets("AutoConvertedSurvey.docx").Select
    Range("A300:N500").Select
    Selection.ClearContents

                               

'101 @ C
    Sheets("AutoConvertedSurvey.docx").Select
    ActiveSheet.Cells(1, 0).Select
    ActiveSheet.Cells.UnMerge
        Cells.Find(What:="D45", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True _
        , SearchFormat:=False).Activate
    ActiveCell.EntireRow.Copy
    Sheets("stage").Select
    Range("a1").Select
    Range("a" & Rows.Count).End(xlUp).Offset(1).Select
    ActiveSheet.Paste
    
    
 '101 @ 30
    Sheets("AutoConvertedSurvey.docx").Select
    ActiveSheet.Cells(1, 0).Select
    ActiveSheet.Cells.UnMerge
        Cells.Find(What:="D46", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True _
        , SearchFormat:=False).Activate
    ActiveCell.EntireRow.Copy
    Sheets("stage").Select
    Range("a1").Select
    Range("a" & Rows.Count).End(xlUp).Offset(1).Select
    ActiveSheet.Paste
    
'102 @ C
    Sheets("AutoConvertedSurvey.docx").Select
    ActiveSheet.Cells(1, 0).Select
    ActiveSheet.Cells.UnMerge
        Cells.Find(What:="D17", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True _
        , SearchFormat:=False).Activate
    ActiveCell.EntireRow.Copy
    Sheets("stage").Select
    Range("a1").Select
    Range("a" & Rows.Count).End(xlUp).Offset(1).Select
    ActiveSheet.Paste
    
    
 '102 @ 30
    Sheets("AutoConvertedSurvey.docx").Select
    ActiveSheet.Cells(1, 0).Select
    ActiveSheet.Cells.UnMerge
        Cells.Find(What:="D18", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True _
        , SearchFormat:=False).Activate
    ActiveCell.EntireRow.Copy
    Sheets("stage").Select
    Range("a1").Select
    Range("a" & Rows.Count).End(xlUp).Offset(1).Select
    ActiveSheet.Paste



Dim C As Integer
C = ActiveSheet.Cells.SpecialCells(xlLastCell).Column
Do Until C = 0
If WorksheetFunction.CountA(Columns(C)) = 0 Then
Columns(C).Delete
End If
C = C - 1
Loop


Sheets("AutoConvertedSurvey.docx").Delete


                                                 
'101 c
    Sheets("Stage").Select
    Range("E2").Select
    Selection.Copy
    Sheets("AN Farm").Select
    Sheets("AN Farm").Range("AD" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    
'101 30
    Sheets("Stage").Select
    Range("E3").Select
    Selection.Copy
    Sheets("AN Farm").Select
    Sheets("AN Farm").Range("AE" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
   
'102 c
    Sheets("Stage").Select
    Range("E4").Select
    Selection.Copy
    Sheets("AN Farm").Select
    Sheets("AN Farm").Range("AI" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    
'102 30
    Sheets("Stage").Select
    Range("E5").Select
    Selection.Copy
    Sheets("AN Farm").Select
    Sheets("AN Farm").Range("AJ" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    

   
   
Sheets("stage").Select
ActiveSheet.Delete



Application.DisplayAlerts = True

Application.ScreenUpdating = True

Application.EnableEvents = True

Application.Calculation = xlCalculationAutomatic

End Sub

Answer 1

There's really too much code there to expect any kind of full review, but I would start by looking at this post How to avoid using Select in Excel VBA and the responses/comments there. Apply those guidelines to your code.

For example this:

Sheets("Stage").Select
Range("D2").Select
Selection.Copy
Sheets("AP Farm").Select
Sheets("AP Farm").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

Can be reduced to:

Sheets("AP Farm").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
    Sheets("Stage").Range("D2").Value

Likewise all repeated blocks of this pattern

'Find tC1 offset WC copy and paste
    Sheets("AutoConvertedSurvey.docx").Select
    ActiveSheet.Cells(1, 0).Select
    ActiveSheet.Cells.UnMerge
        Cells.Find(What:="D36", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True _
        , SearchFormat:=False).Activate
    ActiveCell.EntireRow.Copy
    Sheets("stage").Select
    Range("a1").Select
    Range("a" & Rows.Count).End(xlUp).Offset(1).Select
    ActiveSheet.Paste

are crying out for some kind of refactoring into a separate method, or at least a loop:

'...
Dim el , wsAuto As WorkSheet, wsStage As Worksheet, f As Range
'...
'...
Set wsStage = Thisworkbook.worksheets("stage")
Set wsAuto = Thisworkbook.worksheets("AutoConvertedSurvey.docx")
wsAuto.Cells.UnMerge

For Each el in Array("D45","D46","D17") 'etc etc

    Set f = wsAuto.Cells.Find(What:="D45", After:=wsAuto.Cells(1), 
              LookIn:=xlFormulas, LookAt:= xlPart, _
              SearchOrder:=xlByRows, SearchDirection:=xlNext, _
              MatchCase:=True, SearchFormat:=False)
    
    If Not f Is Nothing Then
        f.EntireRow.Copy wsStage.Cells(Rows.Count, "A").End(xlUp).Offset(1)
    Else
        'what if no match found?
    End If

Next el
'...
'...