Run code on the rest of folders as well instead of single

Question

This below code only works for Single folder what i am looking for is to go for all folder which are avaialble in the master folder.&nbsp;I have 1 Master Folder which contains 10 to 15 subfolders in it and all of them have Excel files.&nbsp;If i have 10 subfolder in the Master_Folder with name like (1,2,3,4,5,6,7,8,9,10) I will run the code and select the "1" code will run and create copy of new folder in it with name&nbsp;"RecoveredWB"&nbsp;then i will go for other folders 1 by 1.&nbsp;I want this code to run for all 10 folder rather than only 1. Your help will be much appreciated.&nbsp;    Dim strFolder As String, strFile As String, wbk As Workbook
    Dim wsh As Worksheet, i As Long
    
    With Application.FileDialog(4)
        If .Show Then
          strFolder = .SelectedItems(1)
        Else
          MsgBox "You haven't selected a folder!", vbExclamation
          Exit Sub
        End If
    End With
    
    If Right(strFolder, 1) &lt;&gt; "\" Then
      strFolder = strFolder &amp; "\"
    End If
    
    Dim wbName As String, arrWb, subFoldNew As String
    subFoldNew = strFolder &amp; "RecoveredWB"
     'create RecoveredWB folder if not existing:
      If Dir(subFoldNew, vbDirectory) = "" Then MkDir subFoldNew
      
    Application.ScreenUpdating = False
    strFile = Dir(strFolder &amp; "*.xlsx")
    Do While strFile &lt;&gt; ""
      Set wbk = Workbooks.Open(strFolder &amp; strFile, CorruptLoad:=xlRepairFile)
      For Each wsh In wbk.Worksheets
      Next wsh
      
      arrWb = Split(wbk.FullName, "\") 'place the full name in an array split by "\"
      wbName = arrWb(UBound(arrWb)) 'the workbook name (without path)
      
      wbk.SaveCopyAs subFoldNew &amp; "\" &amp; wbName
      
      wbk.Close False
      
      strFile = Dir
    Loop
    Application.ScreenUpdating = True&nbsp;&nbsp;

hansvogelaar · Accepted Answer

ShazSh&nbsp;
Try this:
    Dim fso As Object, fld As Object, sfl As Object, fil As Object
    Dim strFolder As String, SubFoldNew As String
    Dim wbk As Workbook, wsh As Worksheet

With Application.FileDialog(4)
        .Title = "Please select the Master folder"
        If .Show Then
            strFolder = .SelectedItems(1)
        Else
            MsgBox "You haven't selected a folder!", vbExclamation
            Exit Sub
        End If
    End With

Application.ScreenUpdating = False

Set fso = CreateObject(Class:="Scripting.FileSystemObject")
    Set fld = fso.GetFolder(strFolder)
    For Each sfl In fld.SubFolders
        SubFoldNew = sfl.Path &amp; "\RecoveredWB"
        If Not fso.FolderExists(SubFoldNew) Then
            fso.CreateFolder SubFoldNew
        End If
        For Each fil In sfl.Files
            If LCase(Right(fil.Name, 5)) = ".xlsx" Then
                Set wbk = Workbooks.Open(fil.Path, CorruptLoad:=xlRepairFile)
                ' Is this loop needed?
                For Each wsh In wbk.Worksheets
                Next wsh
                wbk.SaveCopyAs Filename:=SubFoldNew &amp; "\" &amp; wbk.Name
                wbk.Close SaveChanges:=False
            End If
        Next fil
    Next sfl

Application.ScreenUpdating = True

Forum Discussion

Run code on the rest of folders as well instead of single

Share

Resources