Option Explicit

Public Sub Main()
    Dim ea As Excel.Application, eb As Excel.Workbook, ex As Excel.Worksheet, er As Excel.Range
    Dim r As New ADODB.Recordset, rr As New ADODB.Recordset, rrr As New ADODB.Recordset, rc As ADODB.Recordset, fa As ADODB.FieldAttributeEnum
    Dim iHFile As Integer, sss As String, ms() As String, i As Long, m() As String, sЛист As String, k As Long
    
    iHFile = FreeFile
    Open App.Path & "\restext2.txt" For Binary As #iHFile
    sss = Space(LOF(iHFile))
    Get #iHFile, , sss
    Close #iHFile
    
    fa = adFldIsNullable + adFldMayBeNull + adFldUnknownUpdatable
    r.Fields.Append "Лист", adVarChar,  10 , adFldUnknownUpdatable
    r.Fields.Append "C", adChar,  1 , adFldUnknownUpdatable
    r.Fields.Append "R", adInteger, , adFldUnknownUpdatable
    r.Fields.Append "Value", adVarChar,  20 , fa
    r.Open
    
    rrr.Fields.Append "Лист", adVarChar,  10 , adFldUnknownUpdatable
    rrr.Fields.Append "N", adSmallInt, , adFldUnknownUpdatable
    rrr.Open
    rrr( 0 ).Properties!Optimize = True
    
    ms = Split(sss, "`")
    For i =  0  To UBound(ms)
        m = Split(ms(i), "|")
        If UBound(m) <>  2  Then
            Exit For
        End If
        
        r.AddNew
        r!Лист = m( 0 )
        r!C = Left$(m( 1 ),  1 )
        r!r = CLng(Mid$(m( 1 ),  2 ))
        r!Value = m( 2 )
        r.Update
    Next i
    
    r.Sort = "Лист, C, R"
    Set rc = r.Clone
    rc.Sort = "Лист, C Desc"
    
    ' Определим сколько всего листов
    Do Until r.EOF
        If sЛист <> r( 0 ) Then
            sЛист = r( 0 )
            
            ' Определим максимальную букву листа
            rc.Filter = "Лист='" & sЛист & "'"
            
            rrr.AddNew
            rrr( 0 ) = sЛист
            rrr( 1 ) = Asc(Left$(rc( 1 ),  1 )) - Asc("A") +  1 
            rrr.Update
        End If
        r.MoveNext
    Loop
    Set rc = Nothing
    
    ' Создадим выходной Recordset
    rrr.Sort = "N Desc"
    For i = Asc("A") To Asc("A") + rrr!n -  1 
        rr.Fields.Append Chr$(i), adVarChar,  20 , fa
    Next i
    rr.Fields.Append "Лист", adVarChar,  10 , adFldUnknownUpdatable
    rr.Fields.Append "RRR", adInteger, , fa
    rr.Fields.Append "KKK", adInteger, , adFldUnknownUpdatable
    rr.Open
    
    rrr.Sort = "Лист"
    Do Until rrr.EOF
        sЛист = rrr( 0 )
        r.Filter = "Лист='" & sЛист & "'"
        r.Sort = "R DESC"
        For i =  1  To r( 2 )
            rr.AddNew
            rr!Лист = sЛист
            rr!KKK = i
            rr.Update
        Next i
        rrr.MoveNext
    Loop
    r.Filter =  0 
    r.Sort = "Лист, R"

    ' Заполним выходной Recordset
    r.MoveFirst: sЛист = vbNullString
    Do Until r.EOF
        rr.Filter = "Лист='" & r( 0 ) & "' AND KKK=" & r( 2 )
        rr(CStr(r( 1 ))) = r( 3 )
        rr.Update
        r.MoveNext
    Loop
    
    rrr.MoveFirst
    rr.Filter =  0 
    rr.Sort = "Лист, KKK"
    
    Set ea = New Excel.Application
    Set eb = ea.Workbooks.Add
    For i = ea.Workbooks( 1 ).Worksheets.Count To  2  Step - 1 
        ea.Workbooks( 1 ).Worksheets(i).Delete
    Next i
    Set ex = ea.Workbooks( 1 ).Worksheets( 1 )
    Do Until rrr.EOF
        If rrr.AbsolutePosition >  1  Then
            Set ex = ea.Workbooks( 1 ).Worksheets.Add(, ex)
        End If
        ex.Name = rrr( 0 )
        
        Set r = CloneRecordset(rr, "Лист='" & rrr( 0 ) & "'", "KKK")
        
        Set er = ex.Cells( 1 ,  1 )
        er.CopyFromRecordset r, , rrr( 1 )
        ex.Cells.Columns.AutoFit
        rrr.MoveNext
    Loop
    ea.Workbooks( 1 ).Worksheets( 1 ).Select
    ea.Visible = True
End Sub

Public Function CloneRecordset(rs As ADODB.Recordset, Optional sFilter As String = vbNullString, _
        Optional sSort As String = vbNullString) As ADODB.Recordset

    Dim r As New ADODB.Recordset, rr As ADODB.Recordset, f As ADODB.Field
    Dim iType As ADODB.DataTypeEnum
    
    Set rr = rs.Clone
    rr.Filter = IIf(Len(sFilter), sFilter,  0 )
    If Len(sSort) Then rr.Sort = sSort
    For Each f In rr.Fields
        Select Case f.Type
            Case adNumeric
                iType = adDouble
            Case adChar
                iType = adVarWChar
            Case Else
                iType = f.Type
        End Select
        r.Fields.Append f.Name, iType, f.DefinedSize, adFldIsNullable
    Next
    r.Open
    If Not (rr.BOF And rr.EOF) Then
        rr.MoveFirst
        Do Until rr.EOF
            r.AddNew
            For Each f In rr.Fields
                If Not IsNull(f) Then r.Fields(f.Name) = f
            Next f
            r.Update
            rr.MoveNext
        Loop
    End If
    If r.RecordCount Then r.MoveFirst
    Set CloneRecordset = r
End Function