vba error microsoft excel is waiting for another application to complete an ole action

MHamid

Active Member
Joined
Jan 31, 2013
Messages
357
Hello,

I am getting the following error message when I run the below code. Anything I've done wrong within the code?
"Microsoft excel is waiting for another application to complete an ole action"
It doesn't show where in the code it occurs because it just hangs and I would have to force excel to shut down.


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
 

Some videos you may like

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,576
Trial placing msgbox code at different places within the routine to determine where the code fails. I'm guessing if U place a msgbox before your remove shapes part of the routine, the whole code will work (it takes time to convert and paste your html doc). If this works U may want to add some wait or do events code to replace the msgbox code. HTH. Dave
 

Watch MrExcel Video

Forum statistics

Threads
1,114,235
Messages
5,546,648
Members
410,752
Latest member
MC01_
Top