VBA - перебирает папку.subfolders.files.

Question

Я пишу макрос VBA в Excel, который должен o:

1. При заданном следующем пути петли проходят по подпапкам в этом пути (все подпапки начинаются с порядкового номера)
2. Идет внутри подпапки, которая находится в числовом окне, определенном как входные данные (например, Start_i = 76, Finish_i = 106) и ищет файл Excel (.xlsx или .xlsm), имя которого совпадает с именем этой подпапки
3. Откройте его, измените некоторые указанные c ячейки, сохраните и закройте файл
4. Перейдите к следующей подпапке в окне [76, 106]

Пока что так хорошо.

Проблема, у меня есть папка с 2 файлами (.pdf и .xlxs), и программа возвращает мои 3 файла (.pdf и 2x .xlxs)

Option Explicit
Sub BaKo_Check()
         Dim Name As String, Fa As String, Anlage As String, projekt As String, auxStringPath As String
         Dim Datum As Date
         Dim BeMi As Integer, Start_i As Integer, Finish_i As Integer, BaKo_Nr As Integer
         Dim FSO As New FileSystemObject
         Dim objFSO As Object
         Dim objFolder As Object
         Dim objSubFolder As Object
         Dim file As Object
         Dim fileName As String

     'Get Data from Input Window
     Fa = Range("I2").Text
     projekt = Range("I3").Text
     Name = Range("I4").Text
     Datum = Range("I5").Value
     Start_i = ThisWorkbook.Sheets("Sheet1").Range("I10").Value
     Finish_i = ThisWorkbook.Sheets("Sheet1").Range("I11").Value
     auxStringPath = Range("I8").Text

     'Error Control
     If auxStringPath = "" Then
        Err = 19
        GoTo handleCancel
     End If

     'Create an instance of the FileSystemObject
     Set objFSO = CreateObject("Scripting.FileSystemObject")

     'Get the folder object
     Set objFolder = objFSO.GetFolder(auxStringPath)

     'Loop through subfolders in main Folder
     For Each objSubFolder In objFolder.subfolders
     BaKo_Nr = CInt(Left(objSubFolder.Name, 3))
          If BaKo_Nr >= Start_i Then
               If BaKo_Nr <= Finish_i Then

                    'Loop trough Files in SubFolders
                    For Each file In objSubFolder.Files
                         fileName = FSO.getfilename(CStr(file))
                              If FSO.GetExtensionName(CStr(file)) = "xlsx" Or FSO.GetExtensionName(CStr(file)) = "xlsm" Then
                                   Workbooks.Open fileName:=file
                                   Workbooks(fileName).Sheets("BaKo_neu").Range("C4").Value = projekt
                                   Workbooks(fileName).Sheets("BaKo_neu").Range("C53").Value = Name
                                   Workbooks(fileName).Sheets("BaKo_neu").Range("C54").Value = Datum
                                   Workbooks(fileName).Sheets("BaKo_neu").Range("H2").Value = Fa
                                   Workbooks(fileName).Sheets("BaKo_neu").Range("H4").Value = Mid(fileName, 10, 6)
                                        ThisWorkbook.Sheets("Sheet1").Range("E23").Value = Mid(fileName, 10, 6)
                                   Workbooks(fileName).Sheets("BaKo_neu").Range("C2").Value = ThisWorkbook.Sheets("Sheet1").Range("F23").Value
                                   Workbooks(fileName).Save
                                   Workbooks(fileName).Close
                              End If
                    Next file
               End If
          End If
     Next objSubFolder

handleCancel:
    If Err = 19 Then
        MsgBox "Missing Path"
    End If 

End Sub

Функция кода для 1-го и 2-го файлов, но при переходе к 3-му происходит сбой ...

Может кто-нибудь мне помочь? Большое спасибо

Answer 1

Спасибо, Тим, решил мою проблему. Я интегрировал строку со спецификацией атрибутов, и она работает гладко:

 For Each file In objSubFolder.Files
                         fileName = FSO.getfilename(CStr(file))
                              *If file.Attributes <> 32 Then Exit For*