Merge all excel files from each sub folder

I need your help guys.
I have a master folder named 2022, location (C:\Users\Username\Desktop\2022), in this master folder there are multiple sub folders, in each sub folder there are multiple excel files. I need a VBA code to merge all excel files from each sub folder. A merged file should be created for each sub folder and each merged file should contain only one sheet. Data must be collected only from sheet 1 from each excel file.
My work so far:

Sub MergeExcelFiles()
    
    Dim MasterFolder As String, SubFolder As String, FileName As String
    Dim MergeFile As Workbook, CurrentFile As Workbook
    Dim CurrentSheet As Worksheet, MergeSheet As Worksheet
    
    'Set the path of the master folder
    MasterFolder = "C:\Users\Username\Desktop22\"
    
    'Loop through all subfolders in the master folder
    SubFolder = Dir(MasterFolder & "*", vbDirectory)
    Do While SubFolder <> ""
        If SubFolder <> "." And SubFolder <> ".." Then
            'Create a new workbook to store the merged data
            Set MergeFile = Workbooks.Add
            Set MergeSheet = MergeFile.Sheets(1)
            
            'Loop through all excel files in the subfolder
            FileName = Dir(MasterFolder & SubFolder & "\*.xlsx*")
            Do While FileName <> ""
                'Open the current file and copy data from sheet 1
                Set CurrentFile = Workbooks.Open(MasterFolder & SubFolder & "\" & FileName)
                Set CurrentSheet = CurrentFile.Sheets(1)
                CurrentSheet.UsedRange.Copy Destination:=MergeSheet.Range("A" & MergeSheet.Cells.SpecialCells(xlCellTypeLastCell).Row)
                CurrentFile.Close SaveChanges:=False
                FileName = Dir()
            Loop
            
            'Save the merged data to a new file
            MergeFile.SaveAs Filename:=MasterFolder & SubFolder & "\" & SubFolder & "_Merged.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            MergeFile.Close SaveChanges:=False
        End If
        SubFolder = Dir()
    Loop
    
    MsgBox "Merging completed successfully!"
    
End Sub

The code partially works, first merged file for first sub folder is created but when it should go to the next one, the excel application closes without a single error message.
Any help will be greatly appreciated.

Regards

As suggested by Mr. FunThomas, the code below use fileSystemObject

Sub test()
Dim MasterFolder As String
Dim fs, subF, subFiles, FL
Dim MergeFile As Workbook, MergeSheet As Worksheet

Application.ScreenUpdating = False

MasterFolder = "C:\Users\UserName\Desktop22\"
Set fs = CreateObject("Scripting.FileSystemObject")

    For Each subF In fs.GetFolder(MasterFolder).SubFolders
        Set subFiles = fs.GetFolder(subF).Files
        Set MergeFile = Workbooks.Add
        Set MergeSheet = MergeFile.Sheets(1)
            For Each FL In subFiles
                Workbooks.Open FL
                With ActiveWorkbook
                    .Sheets("Sheet1").UsedRange.Copy Destination:=MergeSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                    .Close SaveChanges:=False
                End With
            Next FL
        With MergeFile
            .SaveAs Filename:=subF & "\" & subF.Name & "_Merged.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            .Close SaveChanges:=False
        End With
    Next subF

Application.ScreenUpdating = True
End Sub