This macro works only for the first document in the folder for deleting the last page and saving to pdf, all of the files are saving to pdf, but i need to delete the past page in every word document first. please can you help me get this to work on every word file in the folder. so that each document is reduced from two pages to one page and saved as one page in the pdf. many thanks


Sub merge()
'Sub ConvertWordsToPdfs()
Dim xIndex As String
Dim xDlg As FileDialog
Dim xFolder As Variant
Dim xNewName As String
Dim xFileName As String
Set xDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xDlg.Show <> -1 Then Exit Sub
Dim lngCharacters As Long
Dim r As Range


With ActiveDocument
lngCharacters = .GoTo(wdGoToPage, wdGoToLast).Start
Set r = .Range(lngCharacters - 1, .Range.End)
r.Delete
End With

xFolder = xDlg.SelectedItems(1) + ""
xFileName = Dir(xFolder & "*.*", vbNormal)
While xFileName <> ""
If ((Right(xFileName, 4)) <> ".doc" Or Right(xFileName, 4) <> ".docx") Then
xIndex = InStr(xFileName, ".") + 1
xNewName = Replace(xFileName, Mid(xFileName, xIndex), "pdf")
Documents.Open FileName:=xFolder & xFileName, _
ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
wdOpenFormatAuto, XMLTransform:=""
ActiveDocument.ExportAsFixedFormat OutputFileName:=xFolder & xNewName, _
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
ActiveDocument.Close
End If
xFileName = Dir()
Wend
End Sub


Function GetFolder() As String


Dim oFolder As Object


GetFolder = ""


Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)


If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path


Set oFolder = Nothing


End Function