Looping through Array of specific folders to perform action ... no subfolders should be included

[dgutsch]

I am struggling with a problem using an array of folders and looping through them to perform an activity. I do not want to get in to any of the sub-folders. When i run the following I get in to some looping issues that I cannot figure out how to resolve. Any assistance is much appreciated. I have commented out certain things i thought could be the cause, but to not avail.

Sub newtest()


Dim fso As Object
Dim objFolder As Object
'Dim objSubFolder As Object
Dim FromPath As String
Dim FileInFolder As Object
Dim i As Integer


FoldersName = Array("Budget Benoit", "Budget Logsdon", "Budget NRL", "Budget Rumfield") '"Budget Trisvan"


FromPath = "F:\Finance\2018\2018 Budget\Budget-OTP\"


Set fso = CreateObject("Scripting.filesystemobject")


For i = 1 To UBound(FoldersName)


  Set objFolder = fso.GetFolder(FromPath & FoldersName(i) & "\")
    
    rowOffset = 1


  Do While objFolder <> ""
    
     For Each FileInFolder In objFolder.Files


    'fileName = Dir(folderPath & "*.xlsx")
    
    'Do While FileInFolder <> ""
    
        'Copy data from dated workbook to associated row in summary sheet
        Workbooks.Open FileInFolder
        
        Sheets("Budget Summary").Range("A12:E12").Copy
        thisWorkbook.Sheets("Sheet1").Range("B1").Offset(rowOffset, 0).PasteSpecial Paste:=xlPasteValues
        
        'Enter file name in column A
        thisWorkbook.Sheets("Sheet1").Range("a1").Offset(rowOffset, 0) = FileInFolder
        
        'Increment to next row
        rowOffset = rowOffset + 1
        
        'Clear the clipboard then close the file with no changes
        Application.CutCopyMode = False
        ActiveWorkbook.Close savechanges:=False
        
        'Get next file name
        
        'FileInFolder = Dir
    
    'Loop
    
     Next FileInFolder


  'Next objFolder
    Loop
    
Next


'Clean up housekeeping
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic


    
    'Determine how many seconds code took to run
    MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")


    'Notify user in seconds
    MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation


End Sub

 

[Kenneth Hobson]

Welcome to the forum!

You seem to have combined the Dir() Loop method with the fso For loop method. Either choose the Dir() method or fso, not both. If you like, I can show you either method. I like the fso method which makes it easy to check if FolderExists or FileExists more reliably.

 

[dgutsch]

thank you Kenneth ... any help is appreciated as I am cobbling together things without fully understanding.

 

[dgutsch]

In a different macro, i know the following works in a specified folder:

Sub Create_Month_Summary()

    Dim folderPath As String
    Dim fileName As String
    Dim thisWorkbook As Workbook
    Dim rowOffset As Long
    
    'To use the timer for tracking
    Dim StartTime As Double
    Dim MinutesElapsed As String
    
        
    'Remember time when macro starts
    StartTime = Timer
        
    'Initial housekeeping
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
        
    Set thisWorkbook = ActiveWorkbook
    
    'Folder containing budget files to be used
    
    folderPath = "F:\Finance\2018\2018 Budget\Budget-OTP\Budget Benoit\"
        
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    rowOffset = 1
    
    fileName = Dir(folderPath & "*.xlsx")
    
    Do While fileName <> ""
    
        'Copy data from dated workbook to associated row in summary sheet
        Workbooks.Open folderPath & fileName
        
        Sheets("Budget Summary").Range("A12:E12").Copy
        thisWorkbook.Sheets("Sheet1").Range("B1").Offset(rowOffset, 0).PasteSpecial Paste:=xlPasteValues
        
        'Enter file name in column A
        thisWorkbook.Sheets("Sheet1").Range("a1").Offset(rowOffset, 0) = fileName
        
        'Increment to next row
        rowOffset = rowOffset + 1
        
        'Clear the clipboard then close the file with no changes
        Application.CutCopyMode = False
        ActiveWorkbook.Close savechanges:=False
        
        'Get next file name
        
        fileName = Dir
    
    Loop
    
    'Clean up housekeeping
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic


    
    'Determine how many seconds code took to run
    MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")


    'Notify user in seconds
    MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation




End Sub

But i need to run through the folders i have tried to load in the array

 

[Kenneth Hobson]

Of course you should be checking if the Sheet name exists before referencing it. You might want to try worksheets(1) instead.

Sub FSOLoopArraySubfolders()
  'Tools > References > Microsoft Scripting Runtime > OK
  'Dim fso As FileSystemObject, objfolder As Folder, FileInFolder As File
  Dim fso As Object, objfolder As Object, FileInFolder as object
  Dim FromPath$, i As Integer, rowOffset As Long, FoldersName
  Dim StartTime As Double, MinutesElapsed$, tf As Boolean
  Dim calc As Integer
  
'***************** INPUT ****************************************************************
  '"Budget Trisvan"
  FoldersName = Array("Budget Benoit", "Budget Logsdon", "Budget NRL", "Budget Rumfield")
  FromPath = "F:\Finance\2018\2018 Budget\Budget-OTP\"
  'FromPath = ThisWorkbook.Path & "\"
'***************** END INPUT ************************************************************

  StartTime = Timer
  
  On Error GoTo CleanHouse
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    calc = .Calculation
    .Calculation = xlCalculationManual
  End With
  
  Set fso = CreateObject("Scripting.filesystemobject")
  tf = fso.FolderExists(FromPath)
  If Not tf Then GoTo CleanHouse
  
  rowOffset = 1
  For i = 0 To UBound(FoldersName)
    If fso.FolderExists(FromPath & FoldersName(i)) = False Then GoTo nextI
    Set objfolder = fso.GetFolder(FromPath & FoldersName(i))
    For Each FileInFolder In objfolder.Files
      If fso.GetExtensionName(FileInFolder.Path) <> "xlsx" Then GoTo NextFileInFolder
      'Copy data from dated workbook to associated row in summary sheet
      'Workbooks.Open FileInFolder
      
      'Sheets("Budget Summary").Range("A12:E12").Copy
      'ThisWorkbook.Sheets("Sheet1").Range("B1").Offset(rowOffset).PasteSpecial Paste:=xlPasteValues
      
      'Enter file name in column A
      'ThisWorkbook.Sheets("Sheet1").Cells(rowOffset, "A") = FileInFolder.Path
        
      'Clear the clipboard then close the file with no changes
      'ActiveWorkbook.Close savechanges:=False
      
      'Increment to next row
      rowOffset = rowOffset + 1
NextFileInFolder:
    Next FileInFolder
nextI:
  Next i

  'Clean up housekeeping
CleanHouse:
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = calc
    .CutCopyMode = False
  End With
  
  'Determine how many seconds code took to run
  MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
  'Notify user in seconds
  If Err.Number <> 0 Then tf = False
  MsgBox "This code ran in " & MinutesElapsed & " minutes.", vbInformation, "Success: " & tf
End Sub

 

[dgutsch]

Kenneth, thank you so much. I am not in a place I can test this right now, but wanted to acknowledge your generous assistance. I will let you know how this works.

 

[dgutsch]

Kenneth, I wanted to get back to you to let you know this worked perfectly. I really appreciate your helping me with this as I had spent several days scouring forums trying to figure it out.