(Solved) – VBA – looping through folder.subfolders.files Crashes


I’m writting a VBA Macro in Excel that should o the following:

  1. Given a following path loops through the subfolders in that path (all subfolders begin with a sequencial number)
  2. Goes inside the subfolder which are in a numerical window defined as input (Start_i=76, Finish_i=106 for instance) and searches for the excel file (.xlsx or .xlsm) which has the same name as that subfolder
  3. Open it, change some specifc cells, saves and close the file
  4. Proccede to the next subfolder in the window [76, 106]

So far so good.

Problem, I have a folder with 2 files (.pdf and .xlxs) and teh program returs my 3 files (.pdf and 2x .xlxs)

enter image description here

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
                              End If
                    Next file
               End If
          End If
     Next objSubFolder

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

End Sub

The code function for the 1st and 2nd files, but when it goes to the 3rd it crashes...

Can someone help me out?
Many Thanks

Non-Visible files are to be shown on my Laptop

Leave a Reply

Your email address will not be published. Required fields are marked *