Run code on Folder and their subfolder

[ShazSh]

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

[#2]

@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

[#3]

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.

[#4 · Accepted solution]

@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

[#5]

thank you very much Sir.

[#6]

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.

[#7]

@ShazSh 

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

[#8]

Sir its still not working when i run the code then nothing happens.

[#9]

@ShazSh 

Sorry, I cannot explain that.

[#10]

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