The following code loops through All files in a specified folder, formats each file, and saves it as a PDF in the same folder.
The code runs fine but there are 2 issues:
1)if there are any files in the folder that are already pdf,s it will open in and mess it up. How can I make this so it only opens the excel files in the folder and not PDF files?
2)if I run it twice it works but it just saves over files if the filename already exists. How can I make I so if when it saves it and the file name already exists it saves it as a new file like filename-b, filename-c filename-d, filename-f ect?
Sub File_Loop_Example()
Dim MyFolder As String, MyFile As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
MyFolder = .SelectedItems(1)
Err.clear
End With
MyFile = Dir(MyFolder & "\", vbReadOnly)
Do While MyFile <> ""
DoEvents
On Error GoTo 0
Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False
Application.Run "PERSONAL.XLSB!TTDA"
ChDir MyFolder
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
MyFolder & "\" & MyFile, Quality:= _
xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
0
Workbooks(MyFile).Close SaveChanges:=False
MyFile = Dir
Loop
End Sub
Try replacing of
MyFile = Dir(MyFolder & "\", vbReadOnly)
with
MyFile = Dir(MyFolder & "\" & "*.xlsx")
In this way, the code will open only .xlsx
files.
Or you can let your code like it is, but filter the files to be open using the next function which retrieves the file extension:
Private Function GetExt(fileName As String) As String
GetExt = Split(fileName, ".")(UBound(Split(fileName, ".")))
End Function
The function can be called just before the workbook opening. Your loop will become something like this:
Do While MyFile <> ""
DoEvents
If GetExt(MyFile) = "xlsx" or GetExt(MyFile) = "xlsm" then
Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False
Application.Run "PERSONAL.XLSB!TTDA"
ChDir MyFolder
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
MyFolder & "\" & MyFile, Quality:= _
xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False
OpenAfterPublish:=True
Workbooks(MyFile).Close SaveChanges:=False
End if
MyFile = Dir
Loop
For the next issue, use please:
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(MyFolder & "\" & MyFile & ".pdf") Then
If fso.FileExists(MyFolder & "\" & MyFile & "_b.pdf") Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:= _
MyFolder & "\" & MyFile & "_a", Quality:= _
xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False
Else
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:= _
MyFolder & "\" & MyFile & "_b", Quality:= _
xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False
End If
Else
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:= _
MyFolder & "\" & MyFile, Quality:= _
xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False
End If
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.