PDF Extraction VBA Code

M

MHamid

Active Member
Joined
Jan 31, 2013
Messages
472
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
Hello,

I have the below code where I will need some assistance.
The code will open a PDF file in Word and copy entire content into an excel sheet. Then it will go through the data an extract some criteria into certain specified cells. The issue that I am having is that not all PDF files are created the same way. So some will have the data I am looking for and others may have a few, but not all data I am looking for. As it is now, if certain fields are not found the macro stops running and I get a debug error. Can someone help with the following? The data is not in a table.

1. Quicker looping through PDF files and extracting data
2. Key Data to Extract
a. Report Issuance Date ... (Somer eports have this as "Issuance Date")
b. Audit Reference Number
c. Rating
d. Accountable Executive(s):
e. Key Measures
f. Issue Relevance and then IBAM for IBAM data

VBA Code: 
Sub PDF_Extraction()
'Macro opens PDF Files as an editable Word Document
'Copies the contents of the Word document
'Pastes the Clipboard contents into Excel

'Declare Variables
    Dim myWorksheet As Worksheet
    Dim wordApp As Object
    Dim myWshShell As wshShell
    Dim strPath
    Dim oDoc As Object
    Dim strFile As String
    Dim registryKey As String
    Dim wordVersion As String
    
'Set Variables
    'Error
        On Error Resume Next
            Set wordApp = GetObject(, "Word.Application")
                If Err Then
                    Set wordApp = CreateObject("Word.Application")
                End If
        On Error GoTo 0
    
    Set myWshShell = New wshShell
    strPath = "C:\Users\mh15601\Desktop\Projects\Audit Plan\2019\Testing\PDF Files\DO NOT DELETE\"
    wordVersion = wordApp.Version
    registryKey = "HKCU\SOFTWARE\Microsoft\Office\" & wordVersion & "\Word\Options\"

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

'Open and Copy PDF Files
    myWshShell.RegWrite registryKey & "DisableConvertPdfWarning", 1, "REG_DWORD"
    
    strFile = Dir$(strPath & "*.pdf")
    
    While strFile <> ""
        Set oDoc = wordApp.Documents.Open(fileName:=strPath & strFile, _
            ConfirmConversions:=False)
        
        'Copy Data from Word
            oDoc.Content.Copy
            
        'Excel
            Set myWorksheet = ActiveWorkbook.Worksheets("PDF FILE")
            With myWorksheet
                .Range("A1").Activate
                .PasteSpecial Format:="HTML"
            End With
        'Remove Shapes
            Dim shp As Shape
                For Each shp In ActiveSheet.Shapes
                   shp.Delete
                Next shp
            
        'Close Word
            oDoc.Close SaveChanges:=0
    'myWshShell.RegWrite registryKey & "DisableConvertPdfWarning", 0, "REG_DWORD"
        
        'Run Excel Macros
            With myWorksheet
                Run ExtractingData
                Run ProcessedAudits
            End With
            
        'Clear Other Sheet
            With Worksheets("Other")
               .Range("A2:E31").Delete Shift:=xlUp
               .Range("M:O").Delete Shift:=xlToLeft
                Range("A2").Select
            End With
        
        'Clear ChartData Sheet
            Sheets("ChartData").Cells.Delete Shift:=xlUp
            Range("A1").Select
            
        'Clear PDF FILE Sheet
            Sheets("PDF FILE").Cells.Delete Shift:=xlUp
            Sheets("PDF FILE").Select
            Range("A1").Select
        
        strFile = Dir$()
    Wend
    
'Clear Word and PDF
    Set wordApp = Nothing
    Set myWshShell = Nothing

'Message Box when Complete
    MsgBox "Complete!"
    
'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
End Sub

Function ExtractingData()
' ExtractingData Macro
' Purpose: Extract PDF Audit Files data from Excel to be processed into SharePoint
' Created by Miriam Hamid
' Created on 9/10/2019
    
'Define Variable
Dim lRow As Long
    
'Set Variable
lRow = Range("A" & Rows.Count).End(xlUp).Row
    
Application.EnableEvents = False

Worksheets("PDF FILE").Activate
           
    With Worksheets("PDF FILE")
    'Clear FindSettings
        Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
            :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
            False, SearchFormat:=False).Activate
     
     'Find "Report Issuance Date" Data and Paste into ChartData tab
        Cells.Find(What:="Report Issuance Date", After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Activate
        Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(1, 0)).Select
        Selection.Copy Destination:=Sheets("Other").Range("A2")
    
     'Find "Audit Reference Number" Data and Paste into ChartData tab
        Sheets("PDF FILE").Select
        Cells.Find(What:="Audit Reference Number", After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Activate
        Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(2, 0)).Select
        Selection.Copy Destination:=Sheets("Other").Range("A3")
        
    'Find "Rating" Data and Paste into ChartData tab
        Sheets("PDF FILE").Select
        Cells.Find(What:="Rating", After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Activate
        Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(1, 0)).Select
        Selection.Copy Destination:=Sheets("Other").Range("A5")
    
    'Find "Executive(s)" Data and Paste into ChartData tab
        Sheets("PDF FILE").Select
        'Cells.Find(What:="Executive(s)", After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Activate
        'ActiveCell.Select
        'Selection.Copy Destination:=Sheets("Other").Range("A7")
    
        Cells.Find(What:="Accountable", After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Activate
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy Destination:=Sheets("Other").Range("M1")
        'Selection.Copy
        'Worksheets("Other").Range("M1").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        
        'Find Responsible and delete cells from Responsible down
            Sheets("Other").Select
            Cells.Find(What:="Responsible", After:=ActiveCell, LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False).Activate
            Range(Selection, Selection.End(xlDown)).Delete Shift:=xlUp
        'Remove "Accountable Execustive(s):" from text
            Columns("M:Q").Select
            Selection.Replace What:="Accountable ", Replacement:="", LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                ReplaceFormat:=False
            Selection.Replace What:="Executive(s):", Replacement:="", LookAt:=xlPart _
                , SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                ReplaceFormat:=False
        'Concatenation Formula
            Range("A7").FormulaR1C1 = "=CONCATENATE(R1C13,R2C13,R3C13,R4C13,R5C13,R6C13,R7C13,R8C13,R9C13,R10C13,R11C13,R12C13,R13C13)"
    
    'Find "Key Measures" Data and Paste into ChartData tab
        Sheets("PDF FILE").Select
        Cells.Find(What:="Key Measures", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
            :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
            False, SearchFormat:=False).Activate
        Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(9, 4)).Select
        Selection.Copy Destination:=Sheets("Other").Range("A9")
        
    'Formula for above data
        Sheets("Other").Select
        Range("E2").FormulaR1C1 = "=R2C1"
        Range("E3").FormulaR1C1 = "=MID(R3C1,FIND(""Audit ID"",R3C1)+9,99)"
        Range("E4").FormulaR1C1 = "=MID(R4C1,FIND(""Report ID"",R4C1)+10,99)"
        Range("E5").FormulaR1C1 = "=MID(R5C1,FIND(""Audit Rating:"",R5C1)+14,99)"
        Range("E6").FormulaR1C1 = "=TRIM(R6C1)"
        Range("E7").FormulaR1C1 = "=TRIM(R7C1)"
        
        Range("E:E").Copy
        Range("E:E").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
        Range("A2").Select
        
    'Find "Issue#" Data and Paste into ChartData tab
        Sheets("PDF FILE").Select
        Cells.Find(What:="Issue #", After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Activate
        Range(Selection, Selection.End(xlToRight).End(xlDown)).Select
        Selection.Copy Destination:=Sheets("ChartData").Range("A1")
        
    'Find "IBAM" Data and Paste into ChartData tab
        Sheets("PDF FILE").Select
     
        Cells.Find(What:="Issue Relevance", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
                :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                False, SearchFormat:=False).Activate
        Cells.Find(What:="IBAM", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
                :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                False, SearchFormat:=False).Activate
        'Range(ActiveCell.Offset(2, 0), ActiveCell.Offset(2, 1)).Select
        Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 1)).Select
        Selection.Copy Destination:=Sheets("ChartData").Range("H1")
        
    'Clear FindSettings
        Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
            :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
            False, SearchFormat:=False).Activate
        
    'Delete non-numeric rows in Column A
        Dim LR3 As Long, i3 As Long
        
        With Sheets("ChartData")
            LR3 = .Range("A" & .Rows.Count).End(xlUp).Row
                For i3 = LR3 To 2 Step -1
                    If Not IsNumeric(.Range("A" & i3).Value) Then .Rows(i3).Delete
                Next i3
        End With
        
        'Sheets("ChartData").Select
        'With Range("A2", Cells(Rows.Count, 1).End(xlUp))
        '     .SpecialCells(xlCellTypeConstants, xlTextValues).EntireRow.Delete
        'End With
        
    'Convert Text to Column IBAM Data
        Sheets("ChartData").Select
        Application.DisplayAlerts = False
        Range("I1").TextToColumns Destination:=Range("J1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
            :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
        Application.DisplayAlerts = True
    End With
    
    'IBAM Formula
        Range("D2:D" & lRow).Formula = "=IFNA(IF(RC[-3]=HLOOKUP(RC[-3],R1C9:R1C32,1,0),""IBAM"",""""),"""")"
        Range("E2:E" & lRow).Formula = "=RC[-2]&"" ""&RC[-1]"
        
        Range("D2:E" & lRow).Copy
        Range("D2:E" & lRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
        
        Range("A1").Select

Application.EnableEvents = True


End Function

Function ProcessedAudits()
'Macro to extract audit data from PDF FILE into Excel
'Created by Miriam Hamid on 9/10/19

'Define Variables
    Dim LR As Long
    Dim LastR As Long
    
'Set Variables
    LR = Sheets("AuditData").Cells(Rows.Count, "A").End(xlUp).Row + 1
    LastR = Range("A" & Rows.Count).End(xlUp).Row

Worksheets("AuditData").Activate

'Add Audit Data
    With Worksheets("AuditData")
        Range("A" & LR).FormulaR1C1 = "=Other!R3C5"
        Range("B" & LR).FormulaR1C1 = "=Other!R7C5"
        Range("C" & LR).FormulaR1C1 = "=Other!R2C5"
        Range("D" & LR).FormulaR1C1 = "=Other!R5C5"
        Range("E" & LR).FormulaR1C1 = "=Other!R4C5"
        Range("F" & LR).FormulaR1C1 = "=Other!R6C5"
        Range("G" & LR).FormulaR1C1 = "=COUNTIF(ChartData!C3,""Level 1"")"
        Range("H" & LR).FormulaR1C1 = "=COUNTIF(ChartData!C3,""Level 2"")"
        Range("I" & LR).FormulaR1C1 = "=COUNTIF(ChartData!C3,""Level 3"")"
        Range("J" & LR).FormulaR1C1 = "=COUNTIF(ChartData!C3,""Level 4"")"
        Range("K" & LR).FormulaR1C1 = "=COUNTIF(ChartData!C3,""Level 5"")"
        Range("L" & LR).FormulaR1C1 = "=SUM(RC[-5]:RC[-1])"
        Range("M" & LR).FormulaR1C1 = "=COUNTIF(ChartData!C5,""Level 1 IBAM"")"
        Range("N" & LR).FormulaR1C1 = "=COUNTIF(ChartData!C5,""Level 2 IBAM"")"
        Range("O" & LR).FormulaR1C1 = "=COUNTIF(ChartData!C5,""Level 3 IBAM"")"
        Range("P" & LR).FormulaR1C1 = "=COUNTIF(ChartData!C5,""Level 4 IBAM"")"
        Range("Q" & LR).FormulaR1C1 = "=COUNTIF(ChartData!C5,""Level 5 IBAM"")"
        Range("R" & LR).FormulaR1C1 = "=SUM(RC[-5]:RC[-1])"
        Range("S" & LR).FormulaR1C1 = "=TRIM(LEFT(SUBSTITUTE('Other'!R16C1,""%"",REPT("" "",100)),100))"
        Range("T" & LR).FormulaR1C1 = "=TRIM(LEFT(SUBSTITUTE('Other'!R16C3,""%"",REPT("" "",100)),100))"
        Range("U" & LR).FormulaR1C1 = "=TRIM(LEFT(SUBSTITUTE('Other'!R17C3,""%"",REPT("" "",100)),100))"
        Range("V" & LR).FormulaR1C1 = "=TRIM(LEFT(SUBSTITUTE('Other'!R18C3,""%"",REPT("" "",100)),100))"
        
        'Copy PasteSpecial Values
        Range("A2:V" & LastR).Copy
        Range("A2:V" & LastR).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
        
        Range("A1").Select
    
    End With

End Function


Thank you,
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
You must log in or register to reply here.

Similar threads

L
  • Locked
  • Question Question
Macros and protecting a cell
Replies
5
Views
114
Fluff
Fluff
L
  • Question Question
How to loop to find and replace with the specific cells
Replies
2
Views
339
Linda Lo
L
V
  • Question Question
US/European Date Format Updates Not Working on Macro Run
Replies
0
Views
128
vancher19
V
R
  • Question Question
cells.find error handling
2
Replies
13
Views
604
jolivanes
jolivanes
S
  • Question Question
Find 1st blank row to fill in when there is an active filter
2
Replies
11
Views
271
Alex Blakenburg
A

Forum statistics

Threads
1,224,813
Messages
6,181,117
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top