Forum Discussion

ShazSh's avatar
ShazSh
Brass Contributor
Oct 06, 2021
Solved

Run code on Folder and their subfolder

I have been using this code since couple of months and I have number of workbooks on which i apply this code to save the exact copy of that workbook with all data.

I am doing this separately for each workbook. I want to apply this code by opening a new workbook, when i run the code it will give me option to select the folder. I want to apply this code on a folder which have multiple workbooks and also on their sub folder.

Your help will be much appreciated.

 

 

Sub stuff()

Dim DISTNAME As String

DISTNAME = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & "New Added" & ".xls"
DISTNAME = ActiveWorkbook.Path & Application.PathSeparator & DISTNAME

Sheets.Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
ActiveWorkbook.SaveAs DISTNAME

End Sub

 

Macros and VBA
  • HansVogelaar's avatar
    HansVogelaar
    Oct 06, 2021

    ShazSh 

    Is this better?

    Sub LoopFolder()
    Dim TopFolder As String
    Dim fso As Object
    Dim fld As Object
    Dim fil As Object
    With Application.FileDialog(4) ' msoFileDialogFolderPicker
        If .Show Then
            TopFolder = .SelectedItems(1) & "\"
        Else
            Beep
            Exit Sub
        End If
    End With
    Application.ScreenUpdating = False
    Set fso = CreateObject(Class:="Scripting.FileSystemObject")
    Set fld = fso.GetFolder(TopFolder)
    Call ProcessFolder(fld)
    Application.ScreenUpdating = True
End Sub

Sub ProcessFolder(ByVal fld As Object)
    Dim sfl As Object
    Dim fil As Object
    For Each fil In fld.Files
        If LCase(Right(fil.Name, 4)) = ".xls" Then
            Workbooks.Open fil.Name
            Call stuff
            ActiveWorkbook.Close
        End If
    Next fil
    For Each sfl In fld.SubFolders
        Call ProcessFolder(sfl)
    Next sfl
End Sub

9 Replies

  • HansVogelaar's avatar
    HansVogelaar
    MVP
    Oct 06, 2021

    ShazSh 

    Try this. Change the path in LoopFolder to the folder you want to process.

    The code calls your Stuff macro.

    Sub LoopFolder()
    Const TopFolder = "C:\Excel\"
    Dim fso As Object
    Dim fld As Object
    Dim fil As Object
    Application.ScreenUpdating = False
    Set fso = CreateObject(Class:="Scripting.FileSystemObject")
    Set fld = fso.GetFolder(TopFolder)
    Call ProcessFolder(fld)
    Application.ScreenUpdating = True
End Sub

Sub ProcessFolder(ByVal fld As Object)
    Dim sfl As Object
    Dim fil As Object
    For Each fil In fld.Files
        If LCase(Right(fil.Name, 4)) = ".xls" Then
            Workbooks.Open fil.Name
            Call stuff
            ActiveWorkbook.Close
        End If
    Next fil
    For Each sfl In fld.SubFolders
        Call ProcessFolder(sfl)
    Next sfl
End Sub
    • ShazSh's avatar
      ShazSh
      Brass Contributor
      Oct 06, 2021
      Sir its not working that way and i have updated the Folder address into "Const TopFolder = " but its not working.

      I would request please update the code so it can ask me to select particular folder and it should run on all workbooks and subfolder workbooks. Looking forward to your help.
      • HansVogelaar's avatar
        HansVogelaar
        MVP
        Oct 06, 2021

        ShazSh 

        Is this better?

        Sub LoopFolder()
    Dim TopFolder As String
    Dim fso As Object
    Dim fld As Object
    Dim fil As Object
    With Application.FileDialog(4) ' msoFileDialogFolderPicker
        If .Show Then
            TopFolder = .SelectedItems(1) & "\"
        Else
            Beep
            Exit Sub
        End If
    End With
    Application.ScreenUpdating = False
    Set fso = CreateObject(Class:="Scripting.FileSystemObject")
    Set fld = fso.GetFolder(TopFolder)
    Call ProcessFolder(fld)
    Application.ScreenUpdating = True
End Sub

Sub ProcessFolder(ByVal fld As Object)
    Dim sfl As Object
    Dim fil As Object
    For Each fil In fld.Files
        If LCase(Right(fil.Name, 4)) = ".xls" Then
            Workbooks.Open fil.Name
            Call stuff
            ActiveWorkbook.Close
        End If
    Next fil
    For Each sfl In fld.SubFolders
        Call ProcessFolder(sfl)
    Next sfl
End Sub

Resources