VBA L oop через путь к файлу и запустить код

Question

У меня есть код ниже, который я хотел бы запустить для всех доступных файлов Excel в папке. В идеале я хотел бы ввести путь к папке в ячейку C3 в Sheet1 и макрос, чтобы применить код ко всем существующим файлам.

Код просто сохранит второй лист каждого файла в PDF версия, она работает совершенно автономно.

Пример пути к папке: C: \ Users \ MMMM \ Рабочий стол \ Project X \ Project II

Рекомендации по подходу к этому?

Private Sub CommandButton1_Click()



    Dim MyFolder As String, MyFile As String



    With Application.FileDialog(msoFileDialogFolderPicker)

       .AllowMultiSelect = False

       .Show

       MyFolder = .SelectedItems(1)

       Err.Clear

    End With


    Application.ScreenUpdating = False

    Application.DisplayStatusBar = False

    Application.EnableEvents = False

    Application.Calculation = xlCalculationManual





    MyFile = Dir(MyFolder & "\", vbReadOnly)



    Do While MyFile <> ""

        DoEvents

        On Error GoTo 0

        Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False


Dim ReportSheet As Worksheet

Dim allColumns As Range



    Set allColumns = Sheets("RT").Columns("N:S")

    allColumns.Hidden = True



    With Worksheets("RT").PageSetup

     .Zoom = False

     .FitToPagesWide = 1

    End With


Filename = ActiveWorkbook.Name



Cell = Replace(Filename, ".xlsx", ".PDF")

Set ReportSheet = Sheets("RT")


Sheets("RT").Select



Sheets("RT").PageSetup.Orientation = xlLandscape



ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _

    ThisWorkbook.Path & "\" & Cell, _

    Quality:=xlQualityStandard, IncludeDocProperties:=True, _

    IgnorePrintAreas:=True, OpenAfterPublish:=True

0

        Workbooks(MyFile).Close SaveChanges:=False

        MyFile = Dir

    Loop


    'turns settings back on that you turned off before looping folders

    Application.ScreenUpdating = True

    Application.DisplayStatusBar = True

    Application.EnableEvents = True

    Application.Calculation = xlCalculationManual


End Sub

Answer 1

Для этого нужна ссылка (см. эту ссылку )

Это не проверено (поэтому дайте мне знать, если что-нибудь появится)

В основном:

1. В соответствии с предложением SmileyFtW он запрашивает у вас папку root
2. Сканирует подпапки для файлов Excel (отрегулируйте расширение в коде)
3. Обрабатывайте процедуру DoSomething, где вы экспортируете файл

РЕДАКТИРОВАТЬ: Добавлен дескриптор пользователя отменить диалог выбора файла

Код:

Option Explicit

' Add a reference to Microsoft Scripting Runtime
' See https://vbaf1.com/filesystemobject/create-microsoft-scripting-runtime-library-reference/

Private Sub ProcessAllFilesInFolder()

    Dim FileSystem As Scripting.FileSystemObject
    Dim fileDialogResult As Office.FileDialog

    Dim folderPath As String

    Set FileSystem = New Scripting.FileSystemObject

    Set fileDialogResult = Application.FileDialog(msoFileDialogFolderPicker)

    With fileDialogResult
        .AllowMultiSelect = False
        .Title = "Select a folder"
        If .Show = True Then
            folderPath = .SelectedItems(1)
        End If
        If .SelectedItems.Count = 0 Then Exit Sub
    End With

    ProcessFolder FileSystem.GetFolder(folderPath)

End Sub

Private Sub ProcessFolder(ByVal targetFolder As Scripting.Folder)
    Dim FileSystem As Scripting.FileSystemObject
    Dim File As Scripting.File
    Dim SubFolder As Scripting.Folder

    Set FileSystem = New Scripting.FileSystemObject

    For Each SubFolder In targetFolder.SubFolders
        ProcessFolder SubFolder
    Next

    For Each File In targetFolder.Files
        If FileSystem.GetExtensionName(File.Name) Like "xls?" And File.Name <> ThisWorkbook.Name Then
            DoSomething File.Path
        End If
    Next
End Sub

Private Sub DoSomething(ByVal filePath As String)

    Dim FileSystem As Scripting.FileSystemObject
    Dim ReportSheet As Worksheet

    Dim targetFileName As String

    targetFileName = Replace(ThisWorkbook.Name, ".xlsm", ".PDF")
    Set ReportSheet = ThisWorkbook.Worksheets("Sheet2")

    ReportSheet.PageSetup.Orientation = xlLandscape
    ReportSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                    ThisWorkbook.Path & "\" & targetFileName, _
                    Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                    IgnorePrintAreas:=True, OpenAfterPublish:=True
End Sub

Дайте мне знать если это работает!