Loop Macros Through Folder

[moni_tm]

Good Evening,

I have the following code which I want to be able to loop through all the files in a folder that will change daily.

The code itself basically opens up a data delimited file, converts to excel and then deletes the original file.
At the moment I can do it one by one and it works great but I'm hoping that i could possibly just select the first file in the folder, press start and it works its way through all of the files until only the xlsx files remain.

below is my code,

Sub Master()

Call D140
Call Save_Delete_Original
End Sub

Private Sub D140()

MsgBox ("Please Select The D140 Report ")
Path = Application.GetOpenFilename
If Path = "False" Then
   MsgBox ("User Cancelled!")
Else
Workbooks.Open Filename:=Path
    HRDATA_file1 = ActiveWorkbook.Name
    
    End If
    
End Sub

Private Sub Save_Delete_Original()

  Dim fn As String
    fn = Application.ActiveWorkbook.FullName
    fn = Replace(fn, "xls", "xlsx")

'save as xlsx
  ActiveWorkbook.SaveAs fn, FileFormat:=51
    
'delete .xls file
  fn = Replace(fn, "xlsx", "xls")
  Kill fn
'saves and closes workbook
  ActiveWorkbook.Close True

End Sub

Thank you for any help.

Tom

 

[pbornemeier]

Test on a copy of your target folder. Step through it a few times.

Option Explicit

Sub ConvertAllFilesInFolder()

    Dim vFilePath As Variant
    Dim FSO As Object
    Dim SourceFolder As Object
    Dim FileItem As Object
    Dim fn As String
    Dim sExt As String
    
    vFilePath = GetFolder(ThisWorkbook.Path)
    
    If vFilePath <> vbNullString Then
    
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set SourceFolder = FSO.GetFolder(vFilePath)
        For Each FileItem In SourceFolder.Files
            sExt = Mid(FileItem.Name, InStrRev(FileItem.Name, "."))
            If sExt = ".xls" Then
                Workbooks.Open Filename:=FileItem
                fn = Application.ActiveWorkbook.FullName
                fn = Replace(fn, "xls", "xlsx")
            
                'save as xlsx
                Application.DisplayAlerts = False   'Prevent personal data warning
                ActiveWorkbook.SaveAs fn, FileFormat:=51
                Application.DisplayAlerts = True
                    
                'delete .xls file
                fn = Replace(fn, ".xlsx", ".xls")
                Kill fn
                'saves and closes workbook
                ActiveWorkbook.Close True
                
            End If
        Next
    End If
    
    Set FSO = Nothing
    Set SourceFolder = Nothing
    Set FileItem = Nothing
    
End Sub

Function GetFolder(Optional strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function