Option Explicit
Dim fsoFile As file, fsoFolder As Folder
Dim key As Variant
Dim dict As Scripting.Dictionary

Sub You()

    'Dim fsoFile As file, fsoFolder As Folder
    Dim ReportFile
    
    Dim fso As New FileSystemObject
    Dim Spath, StrFile, lr, fj, Sal
    Spath = Application.ThisWorkbook.Path & "\"
    Set fsoFolder = fso.GetFolder(Spath)
    
    Set dict = New Scripting.Dictionary
    
    For Each fsoFile In fsoFolder.Files

        If fsoFile Like "*.txt" Then Call sort

    Next fsoFile
    
    SortDictionary dict

    With dict
    
        For Each key In .Keys
        'For key = 1 To 5
            Debug.Print key, .Item(key)
        Next
        
    
    
    
    Range("A1").Resize(, 2) = Array("Values", ".txtName")
'    Range("A2").Resize(5) = Application.Transpose(.Keys)
'    Range("B2").Resize(5) = Application.Transpose(.Items)
    Range("A2").Resize(.Count) = Application.Transpose(.Keys)
    Range("B2").Resize(.Count) = Application.Transpose(.Items)
    '[a1].sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
    'fj = Application.Max(.Keys)
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    'Sal = Application.WorksheetFunction.VLookup(fj, Range("A2:B" & lr), 2, False)
    'MsgBox "Ìàêñèìàëüíîå çíà÷åíèå ñðåäè ôàéëîâ:" & vbNewLine & Application.Max(.Keys) & " â " & Sal
    
    End With
    

    
    
    
  
End Sub

Sub sort()

        Open fsoFile For Input As #1
        Dim s As String
        Dim m, k
        
        While Not EOF(1)
            Input #1, s
            On Error Resume Next
            
            m = (CatchNum(s))
          
            'm = Int(Left(s, 10))
            'm = Split((Split(s, " ")(0)), ",")(1)
            'm = Int(Left(Split(s, ",")(1), 3))
            
            dict.Add m, fsoFile.Name
        Wend
        
        Close #1
        
End Sub

Sub SortDictionary(dict As Object)

    Dim i As Long
    
    With CreateObject("System.Collections.SortedList")
        For Each key In dict
        On Error Resume Next
            .Add key, dict(key)
        Next
        dict.RemoveAll

        For i = 0 To .Keys.Count - 1
            dict.Add .GetKey(i), .Item(.GetKey(i))
        Next
        
    End With
End Sub
Function CatchNum(s As String) As Long
    Dim objRegExp, SubobjMatches
        Set objRegExp = CreateObject("VBScript.RegExp")
        objRegExp.Global = True
        objRegExp.Pattern = "1037604"
        'objRegExp.Pattern = "[^,]+,([\d]+)"
        Set SubobjMatches = objRegExp.Execute(s)
        CatchNum = SubobjMatches(0).Value
End Function