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

Want to improve this question? Update the question so it focuses on one problem only by editing this post.

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 

Welcome to Stackoverflow. I'd recommend having a read of the How to ask page. More specifically, you're not likely to get much help if you just ask for code without showing what you've tried, and what specific problems you've encountered.

Hi @Matt, appreciate your notice, but I think the question is fair enough specific. you're kindly requested to re-evaluate the question and provide support if any.

2 Answers 2

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