Option Explicit

Sub RazborUcastkov()
        Dim nrDic As Object, ucDic As Object, fso As Object, ts As Object, outFile As Object
        Dim ad, arrstr, tArr, t$, tt$, i&, sep_$, el, elel

        Set fso = CreateObject("Scripting.FileSystemObject")

        ' инициализация массива имен файлов с диапазонами номеров книг
        ad = Array( _
             Array("1-й участок", "20100", "20216"), _
             Array("2-й участок", "20257", "20514", "20634", "20636"), _
             Array("4-й участок", "20777"))    ',     "3-й участок")

        Set nrDic = CreateObject("scripting.dictionary")
        nrDic.comparemode = 1
        Set ucDic = CreateObject("scripting.dictionary")
        ucDic.comparemode = 1

        sep_ = Mid(1 / 2, 2, 1)

        For Each el In ad
            If Not ucDic.exists(el(0)) Then ucDic.Add el(0), Array(0, 0, New Collection)
            If IsArray(el) Then
                For i = 1 To UBound(el)
                    nrDic.Item(el(i)) = el(0)
                Next
            End If
        Next

        If Not ucDic.exists("3-й участок") Then ucDic.Add "3-й участок", Array(0, 0, New Collection)

        Set ts = fso.OpenTextFile("c:\Temp\casper200\test.txt", 1)    'Подставьте свой путь к txt-файлу
        arrstr = Split(ts.ReadAll, vbCrLf)    'массив строк текста целиком
        ts.Close
        Set ts = Nothing

        For i = 12 To UBound(arrstr)
            t = Mid(arrstr(i), 9, 5)
            If nrDic.exists(t) Then
                tt = nrDic.Item(t)
                ucDic.Item(tt)(2).Add arrstr(i)
                tArr = ucDic.Item(tt)
                tArr(0) = tArr(0) + Replace(Split(arrstr(i), ";")(1), ".", sep_)
                tArr(1) = tArr(1) + 1
                ucDic.Item(tt) = tArr
            Else
                tt = "3-й участок"
                ucDic.Item(tt)(2).Add arrstr(i)
                tArr = ucDic.Item(tt)
                tArr(0) = tArr(0) + Replace(Split(arrstr(i), ";")(1), ".", ",")
                tArr(1) = tArr(1) + 1
                ucDic.Item(tt) = tArr

            End If
        Next

        For Each el In ucDic
            Set outFile = fso.CreateTextFile("c:\Temp\casper200\test(" & el & ").txt")
            t = Format(ucDic.Item(el)(0), "0.00")
            t = Replace((t), sep_, ".")
            t = Left(t & String(25, " "), 25)
            Mid(arrstr(1), 3, 25) = t
            Mid(arrstr(4), 3, 25) = t
            t = ucDic.Item(el)(1)
            t = Left(t & String(25, " "), 25)
            Mid(arrstr(5), 3, 25) = t

            For i = 0 To 11
                outFile.WriteLine arrstr(i)
            Next

            For Each elel In ucDic.Item(el)(2)
                outFile.WriteLine elel
            Next
            outFile.Close
        Next

        Set outFile = Nothing
        Set fso = Nothing
        Set nrDic = Nothing
        Set ucDic = Nothing
        Erase arrstr
End Sub

Option Explicit

Sub RazborUcastkov()
       Dim fso As Object, ts As Object, outFile As Object, fp$, cnt&
       Dim ad, arrstr, tArr, t$, tt$, i&, sep_$, el, elel

       Set fso = CreateObject("Scripting.FileSystemObject")

       fp = GetFilePath
       If fp = "" Then Exit Sub

       Set ts = fso.OpenTextFile(fp, 1)
       arrstr = Split(ts.ReadAll, vbCrLf)    'массив строк текста целиком
       ts.Close: Set ts = Nothing

       sep_ = Mid(1 / 2, 2, 1)    'десятичный разделитель системы

       ' инициализация массива имен файлов с диапазонами номеров книг
       ad = Array( _
            Array("1-й участок", 20100, 20216), _
            Array("2-й участок", 20257, 20514), _
            Array("3-й участок", 20600, 20633), _
            Array("2-й участок", 20634, 20636), _
            Array("3-й участок", 20637, 20637), _
            Array("4-й участок", 20777, 20777))

       With CreateObject("scripting.dictionary"): .comparemode = 1

           For Each el In ad
               If Not .exists(el(0)) Then .Add el(0), Array(0, 0, New Collection)
           Next: .Add "unknown", Array(0, 0, New Collection)

           For i = 12 To UBound(arrstr)
               t = Split(arrstr(i), ":", 3)(1): tt = "unknown"
               For Each el In ad
                   If --t >= el(1) Then
                       If --t <= el(2) Then tt = el(0): Exit For
                   End If
               Next

               tArr = .Item(tt)
               tArr(0) = tArr(0) + Replace(Split(arrstr(i), ";")(1), ".", sep_)
               tArr(1) = tArr(1) + 1: tArr(2).Add arrstr(i)
               .Item(tt) = tArr
           Next

           fp = Left(fp, Len(fp) - 4)
           For Each el In .keys
               If .Item(el)(1) > 0 Then
                   cnt = cnt + 1
                   Set outFile = fso.CreateTextFile(fp & "(" & el & ").txt")
                   t = Format(.Item(el)(0), "0.00"): t = Replace((t), sep_, "."): t = Left(t & String(25, " "), 25)
                   Mid(arrstr(1), 3, 25) = t: Mid(arrstr(4), 3, 25) = t
                   t = .Item(el)(1): t = Left(t & String(25, " "), 25)
                   Mid(arrstr(5), 3, 25) = t
                   For i = 0 To 11: outFile.WriteLine arrstr(i): Next
                   For Each elel In .Item(el)(2): outFile.WriteLine elel: Next
                   outFile.Close
               End If
           Next
       End With

       Set outFile = Nothing
       Set fso = Nothing
       Erase arrstr
       If cnt > 0 Then
           MsgBox cnt & " файла/ов вида" & vbLf & fp & "(участок)" & vbLf & "созданы!", vbInformation
       Else
           MsgBox "Файлы не созданы!", vbExclamation
       End If
End Sub

Function GetFilePath(Optional ByVal Title As String = "Выберите файл для загрузки", _
                        Optional ByVal InitialPath As String = "C:\Temp\", _
                        Optional ByVal FilterDescription As String = "txt реестр СБРФ", _
                        Optional ByVal FilterExtention As String = "*.txt") As String
' функция выводит диалоговое окно выбора файла с заголовком Title,
' начиная обзор диска с папки InitialPath
' возвращает полный путь к выбранному файлу, или пустую строку в случае отказа от выбора
' для фильтра можно указать описание и расширение выбираемых файлов
       On Error Resume Next
       With Application.FileDialog(msoFileDialogOpen)
           .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
           .Filters.Clear: .Filters.Add FilterDescription, FilterExtention
           If .Show <> -1 Then Exit Function
           GetFilePath = .SelectedItems(1)
       End With
End Function