convert all excel files to pdf in their own subfolder vba - excel

ı would like to convert all excel files to pdf as the whole workbook in subfolders to their original subfolders
I have one solution but my computer is limited. so PowerShell is not supported
How can I convert .XLS & .XLXS files to .PDF format and return them to each original subfolder in Powershell?

This is how I would do it.
http://www.rondebruin.nl/copy5_3.htm
Sub Convert_Excel_To_PDF()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String, Fnum As Long
Dim mybook As Workbook
Dim CalcMode As Long
Dim sh As Worksheet
Dim ErrorYes As Boolean
Dim LPosition As Integer
'Fill in the path\folder where the Excel files are
MyPath = "c:\your_path_here\"
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
LPosition = InStr(1, mybook.Name, ".") - 1
mybookname = Left(mybook.Name, LPosition)
mybook.Activate
'All PDF Files get saved in the directory below:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Documents and Settings\shuerya\Desktop\PDFFiles\" & mybookname & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End If
mybook.Close SaveChanges:=False
Next Fnum
End If
If ErrorYes = True Then
MsgBox "There are problems in one or more files, possible problem:" _
& vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub

Related

VBA - Skip corrupted files

I copied code from another site that opens every Excel file on a path and sets the password to "".
I have 480 Excel files on that path, and the code stops whenever it encounters a corrupted file.
Is there a way to identify every file that is corrupted?
Is there a way to avoid corrupted files?
Sub RemovePasswords()
Dim xlBook As Workbook
Dim strFilename As String
Const fPath As String = "C:\Path\" 'The folder to process, must end with "\"
Const strPassword As String = "openpassword" 'case sensitive
Const strEditPassword As String = "editpassword" 'If no password use ""
strFilename = Dir$(fPath & "*.xls") 'will open xls & xlsx etc
While Len(strFilename) <> 0
Application.DisplayAlerts = False
Set xlBook = Workbooks.Open(FileName:=fPath & strFilename, _
Password:=strPassword, _
WriteResPassword:=strEditPassword)
xlBook.SaveAs FileName:=fPath & strFilename, _
Password:="", _
WriteResPassword:="", _
CreateBackup:=True
xlBook.Close 0
Application.DisplayAlerts = True
strFilename = Dir$()
Wend
End Sub
On the other hand, whenever the code encounters a corrupted file it just stops and doesn't let me know which file is corrupted.
I know that there is a way to put a "if" to skip this errors, but I don't know how to do it.
Please, try the next adapted code:
Sub RemovePasswords()
Dim xlBook As Workbook, strFilename As String
Const fPath As String = "C:\Path\" 'The folder to process, must end with "\"
Const strPassword As String = "openpassword" 'case sensitive
Const strEditPassword As String = "editpassword" 'If no password use ""
strFilename = dir$(fPath & "*.xls") 'will open xls & xlsx etc
While Len(strFilename) <> 0
On Error Resume Next 'skip the error, if the case
Set xlBook = Workbooks.Open(fileName:=fPath & strFilename, _
password:=strPassword, _
WriteResPassword:=strEditPassword)
If err.Number = 0 Then 'if no error:
Application.DisplayAlerts = False
xlBook.saveas fileName:=fPath & strFilename, _
password:="", _
WriteResPassword:="", _
CreateBackup:=True
xlBook.Close 0
Application.DisplayAlerts = True
End If
On Error GoTo 0 'restart raising errors when the case
strFilename = dir$()
Wend
End Sub
I would change the code suggested by FaneDuru a little, in order to comply to your first demand. This code will output corrupt filenames in the debug panel.
Sub RemovePasswords()
Dim xlBook As Workbook
Dim strFilename As String
Const fPath As String = "C:\Path\" 'The folder to process, must end with "\"
Const strPassword As String = "openpassword" 'case sensitive
Const strEditPassword As String = "editpassword" 'If no password use ""
strFilename = Dir$(fPath & "*.xls") 'will open xls & xlsx etc
Application.DisplayAlerts = False
On Error Resume Next
While Len(strFilename) <> 0
Set xlBook = Workbooks.Open(FileName:=fPath & strFilename, _
Password:=strPassword, WriteResPassword:=strEditPassword)
If err.Number = 0 Then
xlBook.SaveAs FileName:=fPath & strFilename, _
Password:="", WriteResPassword:="", CreateBackup:=True
xlBook.Close 0
Else
Debug.Print strFilename 'This will output corrupt filenames in the debug pane
err.Clear
End If
strFilename = Dir$()
Wend
On Error GoTo 0
Application.DisplayAlerts = True
End Sub

VBA Save Visible Cells on Active Sheet as PDF

I have a code that works successfully but I would like to expand on it so that it only exports the visible cells. When it runs it saves the PDF as required but the PDF has lots of blank space.
Sub OrderFormHide()
Worksheets("Order Form").Unprotect "!Product1#"
'AutoFit All Columns on Worksheet
ThisWorkbook.Worksheets("Order Form").Cells.EntireRow.AutoFit
Application.ScreenUpdating = False
'Hide rows with no data requirements
Dim c As Range
For Each c In Range("A:A")
If InStr(1, c, "DELETE") Or InStr(1, c, "DELETE") Then
c.EntireRow.Hidden = True
ElseIf InStr(1, c, "") Or InStr(1, c, "") Then
c.EntireRow.Hidden = False
End If
Next
Worksheets("Order Form").Protect "!Product1#"
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim MyFile As Variant
On Error GoTo errHandler
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strDate = Format(Now(), "ddmmyyyy")
strC = Worksheets("Start Page").Range("$C$10").Value
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for saving file
strFile = strName & "_" & strC & "_" & strDate & ".pdf"
strPathFile = strPath & strFile
'use can enter name and
' select folder for file
MyFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
'export to PDF if a folder was selected
If MyFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=MyFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& MyFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
Application.ScreenUpdating = True
End Sub
I have used bits from previous codes I have built but I cannot figure out how I implement this change. Any assistance will be greatly appreciated.
Please, try implementing the next way. It uses a new helper sheet, copy there the discontinuous range (as continuous), export this sheet and delete it after:
Sub testExportVisibleCellsRange()
Dim sh As Worksheet, shNew As Worksheet, rngVis As Range, strPDF As String
strPDF = ThisWorkbook.path & "\testVisible.pdf"
Set sh = ActiveSheet 'use here the necessary sheet
Set rngVis = sh.UsedRange.SpecialCells(xlCellTypeVisible)
Set shNew = Worksheets.Add(After:=sh)
rngVis.Copy shNew.Range("A1")
shNew.UsedRange.EntireColumn.AutoFit
With shNew.PageSetup
.Orientation = xlPortrait
.FitToPagesWide = 1
End With
shNew.ExportAsFixedFormat Type:=xlTypePDF, fileName:=strPDF
Application.DisplayAlerts = False
shNew.Delete
Application.DisplayAlerts = True
End Sub

Modify multiple excel files - No mistakes, no results

I just need to change the contents of two cells, as you can see, to all the files in a certain folder but nothing happens when the script starts. No mistakes, no results.
Sub ModifyAllFiles()
On Error Resume Next
MyPath = "Macintosh HD:Users:Danespola:Desktop:test"
If MyPath = "" Then Exit Sub
On Error GoTo 0
If Right(MyPath, 1) <> Application.PathSeparator Then
MyPath = MyPath & Application.PathSeparator
End If
FilesInPath = Dir(MyPath, MacID("XLSX"))
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
If Fnum > 0 Then
Do While Filename <> ""
Application.ScreenUpdating = False
Workbooks(FilesInPath).Open
Range("A5").Value = "ca1"
Range("A6").Value = "ca2"
Workbooks(FilesInPath).Save
Workbooks(FilesInPath).Close
Filename = Dir()
Loop
Application.ScreenUpdating = True
End If
End Sub
Thanks!
No need to count the files or build an array just update them as they are found.
Sub ModifyAllFiles()
Dim Filename As String, MyPath As String, count As Integer
Dim wb As Workbook, t0 As Single
t0 = Timer
MyPath = "Macintosh HD:Users:Danespola:Desktop:test"
If Right(MyPath, 1) <> Application.PathSeparator Then
MyPath = MyPath & Application.PathSeparator
End If
' this may not work for excel files created with windows
'Filename = Dir(MyPath, MacID("XLSX"))
Filename = Dir(MyPath)
If Filename = "" Then
MsgBox "No files found"
Exit Sub
Else
Application.ScreenUpdating = False
Do While Filename <> ""
If LCase(Right(Filename, 5)) = ".xlsx" Then
count = count + 1
Set wb = Workbooks.Open(MyPath & Filename)
With wb.Sheets(1)
.Range("A5").Value = "ca1"
.Range("A6").Value = "ca2"
End With
wb.Save
wb.Close
End If
Filename = Dir()
Loop
Application.ScreenUpdating = True
End If
MsgBox count & " files updated", vbInformation, "Finished in " & Int(Timer - t0) & " secs"
End Sub

Excel VBA to convert all Word files in a specific folder to PDF [closed]

Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 4 years ago.
Improve this question
I've found in below link an Excel vba that converts excel files in a specific directory to pdfs.
I want your help to do the needful changes on this code to make it converts Word documents in a specific directory to pdfs.
credits to:
https://www.listendata.com/2013/02/excel-macro-convert-multiple-excel.html
Code is shown below:
Sub ExcelToPDF2()
Dim Path As String, FilesInPath As String _
, OutputPath As String, OutputPath2 As String
Dim MyFiles() As String, Fnum As Long
Dim Buk As Workbook, BukName As String
Dim CalcMode As Long
Dim sh As Worksheet
Dim StartTime As Date, EndTime As Date
Dim LPosition As Integer
'Specify the path of a folder where all the excel files are stored
StartTime = Timer
Path = Range("G6").Text & "\"
OutputPath = Range("G8").Text & "\"
FilesInPath = Dir(Path & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set Buk = Nothing
On Error Resume Next
Set Buk = Workbooks.Open(Path & MyFiles(Fnum))
On Error GoTo 0
If Not Buk Is Nothing Then
LPosition = InStr(1, Buk.Name, ".") - 1
BukName = Left(Buk.Name, LPosition)
Buk.Activate
OutputPath2 = OutputPath & BukName & ".pdf"
On Error Resume Next
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=OutputPath2,
_
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
On Error GoTo 0
End If
Buk.Close SaveChanges:=False
Next Fnum
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
EndTime = Timer
MsgBox "Task succesfully completed in " & Format(EndTime - StartTime,
"0.00") & " seconds"
End Sub
I've finally found the correct VBA I was looking for:
'In your VBA window go to tools then references and add a reference to
'Microsoft Word
Sub Converter()
Dim cnt As Integer, currfile As String
Dim TrimFile As String, Path As String, FilesInPath As String _
, MyFiles() As String, Fnum As Long
Dim CalcMode As Long, LPosition As Long
Dim StartTime As Date, EndTime As Date
Dim objWord As Word.Application
Dim objDoc As Word.Document
ThisWorkbook.Activate
currfile = ActiveWorkbook.Name
Windows(currfile).Activate
Sheets("Sheet1").Activate
StartTime = Timer
Path = Range("C3").Text & "\"
FilesInPath = Dir(Path & "*.doc*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set objWord = CreateObject("Word.Application")
'objWord.Visible = True
On Error Resume Next
Set objDoc = Word.Documents.Open(Path & MyFiles(Fnum))
On Error GoTo 0
If Not objDoc Is Nothing Then
LPosition = InStr(1, objDoc.Name, ".") - 1
TrimFile = Left(objDoc.Name, LPosition)
On Error Resume Next
objDoc.ExportAsFixedFormat OutputFileName:=objDoc.Path & "\" & TrimFile & ".pdf",
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, _
IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
True, UseISO19005_1:=False
End If
objDoc.Close
Next Fnum
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
objWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
EndTime = Timer
MsgBox " Task succesfully completed in " & Format(EndTime - StartTime, "0.00") & "
seconds"
End Sub
Honestly, the easiest way I can think of to do this is to just record a macro. If you go to Word->Developer->Record a Macro, you can record the function that you want to do. From there, you would have the code, and you can change certain areas from there. Here is the code I got with a few tweaks to do what I think you are looking for:
Sub Macro1()
'
' Macro1 Macro
'
'
Dim i As Integer, FileLocation As String, WDoc() As Word.Document
Dim FilesInPath As String, Path As String, MyFiles() As String, iend As Integer
Path = "C:\...\" ' This is where you would like to get the files that need to be exported to .pdfs
NewPath = "C:\...\" ' This is where you would like to send the exported files
FilesInPath = Dir(Path & "*.doc*")
iend = 0
Do While FilesInPath <> ""
iend = iend + 1
ReDim Preserve MyFiles(1 To iend)
MyFiles(iend) = FilesInPath
FilesInPath = Dir()
Loop
For i = 1 To iend
ReDim Preserve WDoc(i)
Set WDoc(i) = Word.Documents.Open(Path & MyFiles(i))
FileLocation = NewPath & WDoc(i).Name & ".pdf" ' Location and name of new file
WDoc(i).ExportAsFixedFormat OutputFileName:=FileLocation, ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, _
IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
True, UseISO19005_1:=False
WDoc(i).Close
Next i
End Sub

Similar VBScript for converting Excel and PowerPoint to PDF

I am looking for a completely lossless way of converting Excel and PowerPoint documents to PDF. I am using this script for Word and it works flawlessly https://gallery.technet.microsoft.com/office/Script-to-convert-Word-08c5154b. I am looking for a similar script for Excel and PowerPoint and cant find one on the internet. I dont have much experience with VB at all so I am confused where it specifies which office application to use. Is there anyone that can provide one for Excel and PowerPoint or someone proficient in VB that would be able to change the script to work with the other packages? I assume its just changing the intent as the programs integrated save as PDF option is the same?
The script for Word is below as well:
Option Explicit
'################################################
'This script is to convert Word documents to PDF files
'################################################
Sub main()
Dim ArgCount
ArgCount = WScript.Arguments.Count
Select Case ArgCount
Case 1
MsgBox "Please ensure Word documents are saved,if that press 'OK' to continue",,"Warning"
Dim DocPaths,objshell
DocPaths = WScript.Arguments(0)
StopWordApp
Set objshell = CreateObject("scripting.filesystemobject")
If objshell.FolderExists(DocPaths) Then 'Check if the object is a folder
Dim flag,FileNumber
flag = 0
FileNumber = 0
Dim Folder,DocFiles,DocFile
Set Folder = objshell.GetFolder(DocPaths)
Set DocFiles = Folder.Files
For Each DocFile In DocFiles 'loop the files in the folder
FileNumber=FileNumber+1
DocPath = DocFile.Path
If GetWordFile(DocPath) Then 'if the file is Word document, then convert it
ConvertWordToPDF DocPath
flag=flag+1
End If
Next
WScript.Echo "Totally " & FileNumber & " files in the folder and convert " & flag & " Word Documents to PDF fles."
Else
If GetWordFile(DocPaths) Then 'if the object is a file,then check if the file is a Word document.if that, convert it
Dim DocPath
DocPath = DocPaths
ConvertWordToPDF DocPath
Else
WScript.Echo "Please drag a word document or a folder with word documents."
End If
End If
Case Else
WScript.Echo "Please drag a word document or a folder with word documents."
End Select
End Sub
Function ConvertWordToPDF(DocPath) 'This function is to convert a word document to pdf file
Dim objshell,ParentFolder,BaseName,wordapp,doc,PDFPath
Set objshell= CreateObject("scripting.filesystemobject")
ParentFolder = objshell.GetParentFolderName(DocPath) 'Get the current folder path
BaseName = objshell.GetBaseName(DocPath) 'Get the document name
PDFPath = parentFolder & "\" & BaseName & ".pdf"
Set wordapp = CreateObject("Word.application")
Set doc = wordapp.documents.open(DocPath)
doc.saveas PDFPath,17
doc.close
wordapp.quit
Set objshell = Nothing
End Function
Function GetWordFile(DocPath) 'This function is to check if the file is a Word document
Dim objshell
Set objshell= CreateObject("scripting.filesystemobject")
Dim Arrs ,Arr
Arrs = Array("doc","docx")
Dim blnIsDocFile,FileExtension
blnIsDocFile= False
FileExtension = objshell.GetExtensionName(DocPath) 'Get the file extension
For Each Arr In Arrs
If InStr(UCase(FileExtension),UCase(Arr)) <> 0 Then
blnIsDocFile= True
Exit For
End If
Next
GetWordFile = blnIsDocFile
Set objshell = Nothing
End Function
Function StopWordApp 'This function is to stop the Word application
Dim strComputer,objWMIService,colProcessList,objProcess
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
'Get the WinWord.exe
Set colProcessList = objWMIService.ExecQuery _
("SELECT * FROM Win32_Process WHERE Name = 'Winword.exe'")
For Each objProcess in colProcessList
'Stop it
objProcess.Terminate()
Next
End Function
Call main
This will convert all Excel files into PDF files.
Sub Convert_Excel_To_PDF()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String, Fnum As Long
Dim mybook As Workbook
Dim CalcMode As Long
Dim sh As Worksheet
Dim ErrorYes As Boolean
Dim LPosition As Integer
'Fill in the path\folder where the Excel files are
MyPath = "c:\Documents and Settings\shuerya\Desktop\ExcelFiles\"
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
LPosition = InStr(1, mybook.Name, ".") - 1
mybookname = Left(mybook.Name, LPosition)
mybook.Activate
'All PDF Files get saved in the directory below:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Documents and Settings\shuerya\Desktop\PDFFiles\" & mybookname & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End If
mybook.Close SaveChanges:=False
Next Fnum
End If
If ErrorYes = True Then
MsgBox "There are problems in one or more files, possible problem:" _
& vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Can you work with that??

Resources