SOLVED

Run code on Folder and their subfolder

%3CLINGO-SUB%20id%3D%22lingo-sub-2818735%22%20slang%3D%22en-US%22%3ERun%20code%20on%20Folder%20and%20their%20subfolder%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2818735%22%20slang%3D%22en-US%22%3E%3CP%3EI%20have%20been%20using%20this%20code%20since%20couple%20of%20months%20and%20I%20have%20number%20of%20workbooks%20on%20which%20i%20apply%20this%20code%20to%20save%20the%20exact%20copy%20of%20that%20workbook%20with%20all%20data.%3C%2FP%3E%3CP%3EI%20am%20doing%20this%20separately%20for%20each%20workbook.%20I%20want%20to%20apply%20this%20code%20by%20opening%20a%20new%20workbook%2C%20when%20i%20run%20the%20code%20it%20will%20give%20me%20option%20to%20select%20the%20folder.%20I%20want%20to%20apply%20this%20code%20on%20a%20folder%20which%20have%20multiple%20workbooks%20and%20also%20on%20their%20sub%20folder.%3C%2FP%3E%3CP%3EYour%20help%20will%20be%20much%20appreciated.%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CPRE%20class%3D%22lia-code-sample%20language-applescript%22%3E%3CCODE%3ESub%20stuff()%0A%0ADim%20DISTNAME%20As%20String%0A%0ADISTNAME%20%3D%20Left(ActiveWorkbook.Name%2C%20Len(ActiveWorkbook.Name)%20-%204)%20%26amp%3B%20%22New%20Added%22%20%26amp%3B%20%22.xls%22%0ADISTNAME%20%3D%20ActiveWorkbook.Path%20%26amp%3B%20Application.PathSeparator%20%26amp%3B%20DISTNAME%0A%0ASheets.Select%0ACells.Select%0ASelection.Copy%0ASelection.PasteSpecial%20Paste%3A%3DxlPasteValues%2C%20Operation%3A%3DxlNone%0AActiveWorkbook.SaveAs%20DISTNAME%0A%0AEnd%20Sub%3C%2FCODE%3E%3C%2FPRE%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-LABS%20id%3D%22lingo-labs-2818735%22%20slang%3D%22en-US%22%3E%3CLINGO-LABEL%3EMacros%20and%20VBA%3C%2FLINGO-LABEL%3E%3C%2FLINGO-LABS%3E%3CLINGO-SUB%20id%3D%22lingo-sub-2818974%22%20slang%3D%22en-US%22%3ERe%3A%20Run%20code%20on%20Folder%20and%20their%20subfolder%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2818974%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F945050%22%20target%3D%22_blank%22%3E%40Valiant%3C%2FA%3E%26nbsp%3B%3C%2FP%3E%0A%3CP%3ETry%20this.%20Change%20the%20path%20in%20LoopFolder%20to%20the%20folder%20you%20want%20to%20process.%3C%2FP%3E%0A%3CP%3EThe%20code%20calls%20your%20Stuff%20macro.%3C%2FP%3E%0A%3CPRE%20class%3D%22lia-code-sample%20language-visual-basic%22%3E%3CCODE%3ESub%20LoopFolder()%0A%20%20%20%20Const%20TopFolder%20%3D%20%22C%3A%5CExcel%5C%22%0A%20%20%20%20Dim%20fso%20As%20Object%0A%20%20%20%20Dim%20fld%20As%20Object%0A%20%20%20%20Dim%20fil%20As%20Object%0A%20%20%20%20Application.ScreenUpdating%20%3D%20False%0A%20%20%20%20Set%20fso%20%3D%20CreateObject(Class%3A%3D%22Scripting.FileSystemObject%22)%0A%20%20%20%20Set%20fld%20%3D%20fso.GetFolder(TopFolder)%0A%20%20%20%20Call%20ProcessFolder(fld)%0A%20%20%20%20Application.ScreenUpdating%20%3D%20True%0AEnd%20Sub%0A%0ASub%20ProcessFolder(ByVal%20fld%20As%20Object)%0A%20%20%20%20Dim%20sfl%20As%20Object%0A%20%20%20%20Dim%20fil%20As%20Object%0A%20%20%20%20For%20Each%20fil%20In%20fld.Files%0A%20%20%20%20%20%20%20%20If%20LCase(Right(fil.Name%2C%204))%20%3D%20%22.xls%22%20Then%0A%20%20%20%20%20%20%20%20%20%20%20%20Workbooks.Open%20fil.Name%0A%20%20%20%20%20%20%20%20%20%20%20%20Call%20stuff%0A%20%20%20%20%20%20%20%20%20%20%20%20ActiveWorkbook.Close%0A%20%20%20%20%20%20%20%20End%20If%0A%20%20%20%20Next%20fil%0A%20%20%20%20For%20Each%20sfl%20In%20fld.SubFolders%0A%20%20%20%20%20%20%20%20Call%20ProcessFolder(sfl)%0A%20%20%20%20Next%20sfl%0AEnd%20Sub%3C%2FCODE%3E%3C%2FPRE%3E%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-2819375%22%20slang%3D%22en-US%22%3ERe%3A%20Run%20code%20on%20Folder%20and%20their%20subfolder%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2819375%22%20slang%3D%22en-US%22%3ESir%20its%20not%20working%20that%20way%20and%20i%20have%20updated%20the%20Folder%20address%20into%20%22Const%20TopFolder%20%3D%20%22%20but%20its%20not%20working.%3CBR%20%2F%3E%3CBR%20%2F%3EI%20would%20request%20please%20update%20the%20code%20so%20it%20can%20ask%20me%20to%20select%20particular%20folder%20and%20it%20should%20run%20on%20all%20workbooks%20and%20subfolder%20workbooks.%20Looking%20forward%20to%20your%20help.%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-2819517%22%20slang%3D%22en-US%22%3ERe%3A%20Run%20code%20on%20Folder%20and%20their%20subfolder%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2819517%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F945050%22%20target%3D%22_blank%22%3E%40Valiant%3C%2FA%3E%26nbsp%3B%3C%2FP%3E%0A%3CP%3EIs%20this%20better%3F%3C%2FP%3E%0A%3CPRE%20class%3D%22lia-code-sample%20language-visual-basic%22%3E%3CCODE%3ESub%20LoopFolder()%0A%20%20%20%20Dim%20TopFolder%20As%20String%0A%20%20%20%20Dim%20fso%20As%20Object%0A%20%20%20%20Dim%20fld%20As%20Object%0A%20%20%20%20Dim%20fil%20As%20Object%0A%20%20%20%20With%20Application.FileDialog(4)%20'%20msoFileDialogFolderPicker%0A%20%20%20%20%20%20%20%20If%20.Show%20Then%0A%20%20%20%20%20%20%20%20%20%20%20%20TopFolder%20%3D%20.SelectedItems(1)%20%26amp%3B%20%22%5C%22%0A%20%20%20%20%20%20%20%20Else%0A%20%20%20%20%20%20%20%20%20%20%20%20Beep%0A%20%20%20%20%20%20%20%20%20%20%20%20Exit%20Sub%0A%20%20%20%20%20%20%20%20End%20If%0A%20%20%20%20End%20With%0A%20%20%20%20Application.ScreenUpdating%20%3D%20False%0A%20%20%20%20Set%20fso%20%3D%20CreateObject(Class%3A%3D%22Scripting.FileSystemObject%22)%0A%20%20%20%20Set%20fld%20%3D%20fso.GetFolder(TopFolder)%0A%20%20%20%20Call%20ProcessFolder(fld)%0A%20%20%20%20Application.ScreenUpdating%20%3D%20True%0AEnd%20Sub%0A%0ASub%20ProcessFolder(ByVal%20fld%20As%20Object)%0A%20%20%20%20Dim%20sfl%20As%20Object%0A%20%20%20%20Dim%20fil%20As%20Object%0A%20%20%20%20For%20Each%20fil%20In%20fld.Files%0A%20%20%20%20%20%20%20%20If%20LCase(Right(fil.Name%2C%204))%20%3D%20%22.xls%22%20Then%0A%20%20%20%20%20%20%20%20%20%20%20%20Workbooks.Open%20fil.Name%0A%20%20%20%20%20%20%20%20%20%20%20%20Call%20stuff%0A%20%20%20%20%20%20%20%20%20%20%20%20ActiveWorkbook.Close%0A%20%20%20%20%20%20%20%20End%20If%0A%20%20%20%20Next%20fil%0A%20%20%20%20For%20Each%20sfl%20In%20fld.SubFolders%0A%20%20%20%20%20%20%20%20Call%20ProcessFolder(sfl)%0A%20%20%20%20Next%20sfl%0AEnd%20Sub%3C%2FCODE%3E%3C%2FPRE%3E%3C%2FLINGO-BODY%3E
Contributor

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

 

9 Replies

@Valiant 

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
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.
best response confirmed by Valiant (Contributor)
Solution

@Valiant 

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
thank you very much Sir.
When i run this code it gives me an option to select the folder after selecting the folder it does nothing. I do not know why. I have added my above code Stuff. But still not working.

@Valiant 

Does this work better?

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
    Dim wbk As Workbook
    For Each fil In fld.Files
        If LCase(Right(fil.Name, 4)) = ".xls" Then
            Set wbk = Workbooks.Open(Filename:=fil)
            Call stuff(wbk)
            wbk.Close SaveChanges:=False
        End If
    Next fil
    For Each sfl In fld.SubFolders
        Call ProcessFolder(sfl)
    Next sfl
End Sub

Sub stuff(wbk As Workbook)
    Dim DISTNAME As String
    wbk.Activate
    Sheets.Select
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    DISTNAME = Left(wbk.Name, Len(wbk.Name) - 4) & "New Added" & ".xls"
    DISTNAME = wbk.Path & Application.PathSeparator & DISTNAME
    wbk.SaveAs Filename:=DISTNAME, FileFormat:=xlExcel8
End Sub
Sir its still not working when i run the code then nothing happens.

@Valiant 

Sorry, I cannot explain that.

Sir, thank you its start working i do not how but now its working. Thank you very much