This was working fine, only sometimes I get this error, but it is happening more and more. Like it will work one a group of invoices, I will try it agian and it works on like half of them the next time. It is breaking at the .Paste Just cant firgure out what it is. I am converting PDF to Excel. This method has given me the best results so for and all my other code that works from the output is already writtten
Sub PDF_To_Excel()
Dim automate_sh As Worksheet
Set automate_sh = ThisWorkbook.Sheets("Automate")
Dim pdf_path As String
Dim excel_path As String
pdf_path = automate_sh.Range("E11").Value
excel_path = automate_sh.Range("E12").Value
Dim fso As New FileSystemObject
Dim fo As Folder
Dim f As File
Set fo = fso.GetFolder(pdf_path)
Dim wa As Object
Dim doc As Object
Dim wr As Object
Set wa = CreateObject("word.application")
wa.Visible = True
Dim nwb As Workbook
Dim nsh As Worksheet
For Each f In fo.Files
Set doc = wa.documents.Open(f.Path, False, Format:="PDF Files")
Set wr = doc.Paragraphs(1).Range
wr.WholeStory
Set nwb = Workbooks.Add
Set nsh = nwb.Sheets(1)
wr.Copy
nsh.Paste
nwb.SaveAs (excel_path & "\" & Replace(f.Name, ".pdf", ".xlsx"))
doc.Close False
nwb.Close False
Next
wa.Quit
MsgBox "Done"
End Sub
Related
I have a question regarding the following code. The code now works, but did not until I set the Variables to nothing (see the part with the *** in the code). I got all kinds of error-messages (e.g. "462 The remote server machine does not exist or is unavailable")
My question is: Why do I have to Set those Variables to nothing? I guess it has something to do with the fact that I use a loop right?
Thanks in advance!
Sub Saveas_PDF()
Dim PP As PowerPoint.Presentation
Dim prs As PowerPoint.Presentation
Dim Sl As PowerPoint.Slide
Dim sh As Variant
Dim company As String
Set Dropdown.ws_company = Tabelle2
company = Dropdown.ws_company.Range("C2").Value
Dim strPOTX As String
Dim strPfad As String
Dim pptApp As Object
Call filepicker
Dim Cell As Range
For Each Cell In Dropdown.ws_company.Range(Dropdown.ws_company.Cells(5, 3),
Dropdown.ws_company.Cells(Rows.Count,
3).End(xlUp)).SpecialCells(xlCellTypeVisible)
Dropdown.ws_company.Range("C2") = Cell
Set pptApp = New PowerPoint.Application
Dim pptVorlage As String
pptVorlage = myfilename
Set PP = pptApp.Presentations.Open(pptVorlage)
PP.UpdateLinks 'Datei --> Informationen --> Verknüpfungen --> Automatisch
aktualisieren Haken setzen
Dim newpath As String
newpath = Replace(myfilename, "AXO", "" & Cell & " AXO")
Dim newpathpdf As String
newpathpdf = Replace(newpath, "pptx", "pdf")
PP.ExportAsFixedFormat "" & newpathpdf & "", ppFixedFormatTypePDF,
ppFixedFormatIntentPrint
pptApp.Visible = True
Debug.Print (PP.Name)
AppActivate (PP.Name)
PP.Close
***Set pptApp = Nothing
Set PP = Nothing***
Next
Set pptApp = New PowerPoint.Application
If IsAppRunning("PowerPoint.Application") Then
If pptApp.Windows.Count = 0 Then
pptApp.Quit
End If
End If
End Sub
Maybe because you are calling the constructor "New" inside de loop in the line: Set pptApp = New PowerPoint.Application
Move the line "Set pptApp = New PowerPoint.Application" before de foreach and try it.
I am writing a VBA macro to convert excel workbooks to PDF.
The wkb.PrintOut method works fine for some excel files. But for the others, it will print the first worksheet to the file name I supplied, and prompt me for the file name to save for the remaining worksheets.
Why does the PrintOut function behaves such a way? How do I let it print the entire workbook into a single file name I set?
Public Sub ConvertToPDF()
Dim ws As Worksheet
Dim inputQueue As Collection
Dim outputQueue As Collection
Dim r As Integer, c As Integer
Dim objFSO As FileSystemObject
Dim objInputFolder As Folder
Dim objOutputFolder As Folder
Dim objInputFile As File
Dim fileExt As String
Set ws = Worksheets("XLPrint")
Set objFSO = New FileSystemObject
Set inputQueue = New Collection
Set outputQueue = New Collection
Application.ActivePrinter = "Microsoft Print to PDF on Ne02:"
Application.DisplayAlerts = False
r = ws.Range("folder_name").Row + 1
c = ws.Range("folder_name").Column
ClearCollection inputQueue
ClearCollection outputQueue
While (ws.Cells(r, c).Value <> "")
inputQueue.Add objFSO.GetFolder(ws.Cells(r, c).Value)
outputQueue.Add objFSO.GetFolder(ws.Cells(r, c + 1).Value)
r = r + 1
Wend
Application.ScreenUpdating = False
Do While inputQueue.Count > 0
Set objInputFolder = inputQueue(1)
inputQueue.Remove 1
Set objOutputFolder = outputQueue(1)
outputQueue.Remove 1
For Each objInputFile In objInputFolder.Files
fileExt = Mid(objInputFile.ShortName, InStr(objInputFile.ShortName, ".") + 1)
Select Case UCase(fileExt)
Case "XLSX", "XLSM", "XLS"
Call PrintXLToPDF(objInputFile, objOutputFolder)
Case "DOCX", "DOC"
Call PrintWordToPDF(objInputFile, objOutputFolder)
End Select
Next objInputFile
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set objFSO = Nothing
Set ws = Nothing
Set inputQueue = Nothing
Set outputQueue = Nothing
MsgBox "Done"
End Sub
Public Sub PrintXLToPDF(ByVal objInputXL As File, ByVal objOutputFolder As Folder)
Dim wkb As Workbook
Dim outputFileName As String
Set wkb = Workbooks.Open(objInputXL.Path)
outputFileName = objOutputFolder.ShortPath & "\" & Mid(objInputXL.Name, 1, InStr(objInputXL.Name, ".") - 1) & ".pdf"
wkb.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False, PrToFileName:=outputFileName, ActivePrinter:="Microsoft Print to PDF on Ne02:"
wkb.Close SaveChanges:=False
Set wkb = Nothing
End Sub
Try just saving it directly as PDF instead of printing:
wkb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=outputFileName, Quality:=xlQualityStandard
Many thanks
I combined the Plagon's answer and the answer of the
HackSlash and my problem was solved
The problem is solved when yuo save the Woorkbook (ActiveWorkbook.Save) and then use the line suggested by HackSlash (wkb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=outputFileName, Quality:=xlQualityStandard
)
I'm trying to write a macro that will generate a Microsoft Word 'report' from an Excel file. I want for the macro to navigate to bookmarks in a Word template for the report, and insert at each certain content or a chart from the native Excel file. The macro works when running in piecemeal, but altogether fails to execute, with Excel repeating over and over that "[It] is waiting for another application to complete an OLE action."
To clarify also, the macro first clears a certain 'data dump' region in the workbook (its native file) and repopulates it with new data from a specified file. This file (its location path) and the various 'target row' and 'identifier' variables you see in the code are inputted by the user to a sort of interface (just a worksheet in the native workbook), where each is labeled manually as a (named) range to be easily fed into to be used by the code. The macro then creates the report by going through the different sheets of the workbook, copying certain content, and turning to Word to paste the copied content at template locations indicated by bookmarks.
I'm completely perplexed by the 'OLE error'. Any ideas about this/the code otherwise? Please share. Thanks for your help!
Sub GenerateReport()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim myWorkbook As Excel.Workbook
Set myWorkbook = ThisWorkbook
Dim myWorksheet As Excel.Worksheet
Set myWorksheet = myWorkbook.Sheets("Sheet1")
Dim myWorksheet2 As Excel.Worksheet
Set myWorksheet2 = myWorkbook.Sheets("Sheet2")
Dim myWorksheet3 As Excel.Worksheet
Set myWorksheet3 = myWorkbook.Sheets("Sheet3")
Dim FileName As String
FileName = myWorksheet.Range("FileName")
Dim FilePath As String
FilePath = myWorksheet.Range("FilePath")
Dim TargetSheetName As String
TargetSheetName = myWorksheet.Range("TargetSheetName")
Dim PasteSheetName As String
PasteSheetName = myWorksheet.Range("PasteSheetName")
Dim Identifier As String
Identifier = myWorksheet.Range("Identifier")
Dim Identifier2 As String
Identifier2 = myWorksheet.Range("Identifier2")
Dim TargetRow As String
TargetRow = myWorksheet.Range("TargetRow")
Dim TargetRow2 As String
TargetRow2 = myWorksheet.Range("TargetRow2")
Dim PasteIdentifier As String
PasteIdentifier = myWorksheet.Range("PasteIdentifier")
Dim PasteIdentifier2 As String
PasteIdentifier2 = myWorksheet.Range("PasteIdentifier2")
Dim PasteTargetRow As String
PasteTargetRow = myWorksheet.Range("PasteTargetRow")
Dim PasteTargetRow2 As String
PasteTargetRow2 = myWorksheet.Range("PasteTargetRow2")
Dim Text As String
Text = myWorksheet.Range("Text")
Dim Text2 As String
Text2 = myWorksheet.Range("Text2")
Dim Text3 As String
Text3 = myWorksheet.Range("Text3")
Dim ReportTemplateFilePath As String
ReportTemplateFilePath = myWorksheet.Range("ReportTemplateFilePath")
Dim ReportTemplateFileName As String
ReportTemplateFileName = myWorksheet.Range("ReportTemplateFileName")
Dim SaveToLocation As String
SaveToLocation = myWorksheet.Range("SaveToLocation")
Dim SourceTargetSheet As Excel.Worksheet
Set SourceTargetSheet = myWorkbook.Sheets(PasteSheetName)
Dim TargetWorkbook As Excel.Workbook
Set TargetWorkbook = Workbooks.Open(FilePath)
Dim TargetSheet As Excel.Worksheet
Set TargetSheet = TargetWorkbook.Sheets(TargetSheetName)
'Clear old info
Dim UpperLeftHandCornerOfClear As String
UpperLeftHandCornerOfClear = "A" & PasteTargetRow
Dim LowerRightHandCornerOfClear As String
LowerRightHandCornerOfClear = "XFD" & PasteTargetRow2
SourceTargetSheet.Range(UpperLeftHandCornerOfClear, LowerRightHandCornerOfClear).ClearContents
'Copy new info for pasting
Dim StartingColumnAsRange As Range
Set StartingColumnAsRange = TargetSheet.Cells.Find(Identifier, LookIn:=xlValues, LookAt:=xlPart)
If Not StartingColumnAsRange Is Nothing Then
Dim StartingColumn As String
StartingColumn = Split(StartingColumnAsRange.Address, "$")(1)
End If
Dim EndingColumnAsRange As Range
Set EndingColumnAsRange = TargetSheet.Cells.Find(Identifier2, LookIn:=xlValues, LookAt:=xlPart)
If Not EndingColumnAsRange Is Nothing Then
Dim EndingColumn As String
EndingColumn = Split(EndingColumnAsRange.Address, "$")(1)
End If
Dim UpperLeftHandCornerOfCopy As String
UpperLeftHandCornerOfCopy = StartingColumn & TargetRow
Dim LowerRightHandCornerOfCopy As String
LowerRightHandCornerOfCopy = EndingColumn & TargetRow2
TargetSheet.Range(UpperLeftHandCornerOfCopy, LowerRightHandCornerOfCopy).Copy
Dim PastePasteTarget As String
PastePasteTarget = "A" & PasteTargetRow
SourceTargetSheet.Range(PastePasteTarget).PasteSpecial Paste:=xlPasteValues
'Create a Microsoft Word object (instance of Word to control)
Dim WordApplication As Word.Application
Set WordApplication = CreateObject("Word.Application")
'Error handle if Microsoft Word is open
On Error Resume Next
Set WordApplication = GetObject(class:="Word.Application")
Err.Clear
If WordApplication Is Nothing Then
Set WordApplication = CreateObject(class:="Word.Application")
End If
On Error GoTo 0
'Error handle if report template is specifically already open
On Error Resume Next
Application.DisplayAlerts = False
Documents(ReportTemplateFileName).Close SaveChanges:=wdDoNotSaveChanges
On Error GoTo 0
Application.DisplayAlerts = True
Dim WordDocument As Word.Document
Set WordDocument = WordApplication.Documents.Open(ReportTemplateFilePath)
'Content from 'myWorksheet'
With WordDocument
.Bookmarks("Bookmark1").Range.Text = myWorksheet.Range("Text1")
.Bookmarks("Bookmark2").Range.Text = myWorksheet.Range("Text2")
.Bookmarks("Bookmark3").Range.Text = myWorksheet.Range("Text3")
.Bookmarks("Bookmark4").Range.Text = myWorksheet.Range("Text4")
End With
'Content from 'myWorksheet2'
With WordDocument
.Bookmarks("Bookmark5").Range.Text = myWorksheet2.Range("Text5")
.Bookmarks("Bookmark6").Range.Text = myWorksheet2.Range("Text6")
.Bookmarks("Bookmark7").Range.Text = myWorksheet2.Range("Text7")
.Bookmarks("Bookmark8").Range.Text = myWorksheet2.Range("Text8")
.Bookmarks("Bookmark9").Range.Text = myWorksheet2.Range("Text9")
.Bookmarks("Bookmark10").Range.Text = myWorksheet3.Range("Text10")
End With
'Chart (alone on worksheet)
WordApplication.Selection.Goto What:=wdGoToBookmark, Name:="Chart1"
ThisWorkbook.Sheets("Chart 1 Worksheet Name").ChartObjects(1).Copy
WordApplication.Selection.Paste
WordApplication.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
'Two charts grouped together
WordApplication.Selection.Goto What:=wdGoToBookmark, Name:="Chart2"
ThisWorkbook.Sheets("Chart 2 Worksheet Name").ChartObjects(1).Copy
WordApplication.Selection.Paste
WordApplication.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
With WordDocument
.SaveAs FileName:=SaveToLocation & " " & Text3, _
FileFormat:=wdFormatDocumentDefault
.Close
End With
WordApplication.Quit
Set WordApplication = Nothing
Set WordDocument = Nothing
Application.ScreenUpdating = True
'Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
myWorksheet.Activate
MsgBox "Report successfully generated.", vbInformation, "Completed!"
End Sub
Try modifying your Word application creation script - this is all you need:
On Error Resume Next
Set WordApplication = GetObject(class:="Word.Application")
On Error GoTo 0
If WordApplication Is Nothing Then
Set WordApplication = CreateObject(class:="Word.Application")
End If
It may be that Word is waiting for some input from you but you're not seeing it because you didn't make the instance visible, so try also adding:
WordApplication.Visible = True
I am looking in the Folder for specific file in .docx and want to open it. I put the Name of X into Inputbox, go to Sheet Y, look on the next right cell of X and open this as Word (next cell right is an file in word I want to open). It is working, but the Problem is that the target Word Doc may be in multiples subfolders. Is there any quick way to search in These subfolder?
Private Sub CommandButton1_Click()
On Error GoTo ErrorHandling
Application.ScreenUpdating = False
Dim AppWD As Object
Dim SearchX As String
Dim SearchArea As Range
Dim Y As String
Dim sPath As String
sPath = "C:\Users\VS\Desktop\test"
SearchRule = InputBox("X")
Set SearchArea = Sheets("Look").Range("A:A").Find(what:=SearchX, _
LookIn:=xlFormulas, lookat:=xlWhole)
ActiveWindow.Visible = True
Target = SearchArea.Offset(0, 1).Value
Set AppWD = CreateObject("Word.Application")
AppWD.Visible = True
AppWD.documents.Open (sPath & "\" & Target & "." & "docx")
ErrorHandling: Exit Sub
End Sub
My take on searching throught subfolders
Sub searchSub()
Dim fso As FileSystemObject, fFile As File, fFolder As Folder
Dim fSubFolder As Folder, fPath As String, FileToSearch As String
Set fso = New FileSystemObject
FileToSearch = "SomeDocument.docx"
fPath = ThisWorkbook.Path
Set fFolder = fso.GetFolder(fPath)
For Each fFolder In fFolder.SubFolders
Set fSubFolder = fso.GetFolder(fFolder.Path)
For Each fFile In fSubFolder.Files
If fFile.Name = FileToSearch Then
'do something with file
End If
Next fFile
Next fFolder
End Sub
I have the following code as part of my sub trying to assign a range:
'Set xlApp = CreateObject("Excel.Application")
Dim xlApp As Object
Set xlApp = GetObject(, "Excel.Application")
xlApp.Visible = False
xlApp.ScreenUpdating = False
Dim CRsFile As String
Dim CRsMaxRow As Integer
' get the CR list
CRsFile = "CRs.xls"
Set CRsWB = xlApp.Workbooks.Open("C:\Docs\" + CRsFile)
With CRsWB.Worksheets("Sheet1")
.Activate
CRsMaxRow = .Range("A1").CurrentRegion.Rows.Count
Set CRs = .Range("A2:M" & CRsMaxRow)
End With
Dim interestingFiles As Range
' get the files names that we consider interesting to track
Set FilesWB = xlApp.Workbooks.Open("files.xlsx")
With FilesWB.Worksheets("files")
.Activate
Set interestingFiles = .Range("A2:E5")
End With
Do you have any idea why am I getting a run time type mismatch error?
If you run the code from Word then the problem is in the declaration of 'interestingFiles' variable. Range exist in Word as well so use either Variant or add reference to Excel and then use Excel.Range.
Without Excel reference:
Dim interestingFiles As Variant
And with Excel reference:
Dim interestingFiles As Excel.Range
Kindly set xlApp object as in below code.
Also you provide complete path for your workbook when opening it.
Sub test()
Dim interestingFiles As Range
Dim xlApp As Object
Set xlApp = GetObject(, "Excel.Application")
' get the files names
Dim path As String
path = "C:\Users\Santosh\Desktop\file1.xlsx"
Set FilesWB = xlApp.Workbooks.Open(path)
With FilesWB.Worksheets(1)
.Activate
Set interestingFiles = .Range("A2:E5")
End With
End Sub