Extracting data from similar cell in 720 excel files that in 12 folders

Option Explicit
Const msSourceSheet As String = "Amine"
Const msSourceCell As String = "F26"
Const msTargetSheet As String = "Sheet2"
Dim moDataDictionary As Object

Sub ExtractData()
Dim lFolderPtr As Long

Set moDataDictionary = Nothing
Set moDataDictionary = CreateObject("Scripting.Dictionary")

' Open the file dialog & prompt for appropriate folder
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = True
    .Show
    If .SelectedItems.Count > 0 Then
        For lFolderPtr = 1 To .SelectedItems.Count
            ProcessFolder CStr(.SelectedItems(lFolderPtr))
        Next lFolderPtr
    Else
        MsgBox "Macro abandoned"
    End If
End With

End Sub
        
Private Sub ProcessFolder(ByVal Folder As String)
Dim FSO As Object, fsoFolder As Object, fsoFC As Object, fsoFL As Object
Dim iShiftPtr As Integer
Dim lFileCount As Long, lCurFile As Long, lReportInterval As Long
Dim lPtr1 As Long, lPtr2 As Long
Dim sCurfile As String, sKey As String
Dim vaData() As Variant
Dim vaDataKeys As Variant
Dim wbCur As Workbook

Set FSO = Nothing
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fsoFolder = FSO.GetFolder(Folder)
Set fsoFC = fsoFolder.Files
lFileCount = fsoFolder.Files.Count
lCurFile = 0
lReportInterval = 1
For Each fsoFL In fsoFC
    lCurFile = lCurFile + 1
    sCurfile = CStr(fsoFL.Name)
    lReportInterval = lReportInterval - 1
    If lReportInterval < 1 Then
        lReportInterval = 10
        With Application
            .ScreenUpdating = True
            .StatusBar = "Processing file " & lCurFile & " of " & lFileCount & ": " & sCurfile
            .ScreenUpdating = False
        End With
    End If
    
    '-- Check filename is format '999999_M.xls' or '999999_N.xls' --
    If Len(sCurfile) = 12 Then
        Select Case LCase$(Right$(sCurfile, 6))
        Case "_m.xls"
            iShiftPtr = 2
        Case "_n.xls"
            iShiftPtr = 3
        Case Else
            iShiftPtr = 0
        End Select
        If iShiftPtr <> 0 Then
            sKey = Left$(sCurfile, 6)
            If IsNumeric(sKey) Then
                If moDataDictionary.exists(sKey) Then
                    vaData = moDataDictionary.Item(sKey)
                    moDataDictionary.Remove key:=sKey
                Else
                    ReDim vaData(1 To 1, 1 To 3)
                    vaData(1, 1) = Left$(sKey, 6)
                End If
                
                Application.EnableEvents = False
                Set wbCur = Workbooks.Open(FileName:=Folder & Application.PathSeparator & sCurfile, _
                                         ReadOnly:=True)
                On Error Resume Next
                vaData(1, iShiftPtr) = wbCur.Sheets(msSourceSheet).Range(msSourceCell).Value
                wbCur.Close savechanges:=False
                Application.EnableEvents = True
                moDataDictionary.Add key:=sKey, Item:=vaData
            End If
        End If
    End If
Next fsoFL

vaDataKeys = moDataDictionary.keys
'-- Sort the entries --
For lPtr1 = 0 To UBound(vaDataKeys) - 1
    For lPtr2 = lPtr1 + 1 To UBound(vaDataKeys)
        sKey = vaDataKeys(lPtr2)
        If vaDataKeys(lPtr1) > sKey Then
            vaDataKeys(lPtr2) = vaDataKeys(lPtr1)
            vaDataKeys(lPtr1) = sKey
        End If
    Next lPtr2
Next lPtr1

ReDim vaData(1 To 1, 1 To 3)
vaData(1, 1) = "Date"
vaData(1, 2) = "Morning"
vaData(1, 3) = "Night"

With ThisWorkbook.Sheets(msTargetSheet)
    .UsedRange.ClearContents
    .Range("A1:C1").Value = vaData
    For lPtr1 = 0 To UBound(vaDataKeys)
        ReDim vaData(1 To 1, 1 To 3)
        vaData = moDataDictionary.Item(vaDataKeys(lPtr1))
        lPtr2 = lPtr1 + 2
        .Range("A" & lPtr2 & ":C" & lPtr2).Value = vaData
    Next lPtr1
End With

moDataDictionary.RemoveAll
Set moDataDictionary = Nothing

Application.StatusBar = False

End Sub