Forum Discussion

Copper 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 eac...

Macros and VBA

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

ShazSh

Copper Contributor

Oct 08, 2021

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.

HansVogelaar

MVP

Oct 08, 2021

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

ShazSh
Copper Contributor
Oct 08, 2021
Sir its still not working when i run the code then nothing happens.
- HansVogelaar
  MVP
  Oct 08, 2021
  ShazSh
  
  Sorry, I cannot explain that.
  - ShazSh
    Copper Contributor
    Oct 11, 2021
    Sir, thank you its start working i do not how but now its working. Thank you very much