Разбиение текстового файла (в т.ч. CSV) на несколько файлов с заданным количеством строк

Sub ПримерИспользованияФункции_SplitTextFile()
    ИмяРазбиваемогоФайла$ = "C:\test\2011 04 17  12-32-30.csv"
    МаксимальноеКоличествоСтрокВфайле& = 3
 
    Dim СписокИмёнФайлов As Collection
    Set СписокИмёнФайлов = SplitTextFile(ИмяРазбиваемогоФайла$, МаксимальноеКоличествоСтрокВфайле&, vbNewLine, False)
 
    For Each Файл In СписокИмёнФайлов
        Debug.Print "Создан файл: " & Файл
    Next
End Sub

Function SplitTextFile(ByVal filename$, ByVal MaxRowsCount&, ByVal Delimiter$, _
                       Optional ByVal DeleteSourceFile As Boolean = True) As Collection
    ' функция предназначена для разбивки текстового файла filename$ на несколько файлов
    ' меньшего размера - в каждом из которых будет не более MaxRowsCount& строк
    ' Разделение строк выполняется с использованием разделителя Delimiter$
    ' Создаваемые файлы получают имена вида filename(1).txt, filename(2).txt и т.д.
    ' Если DeleteSourceFile = TRUE, - то исходный файл удаляется после разбивки
    ' Возвращает коллекцию имён созданных файлов

    ext$ = "." & Split(filename$, ".")(UBound(Split(filename$, ".")))
    Set fso = CreateObject("scripting.filesystemobject")
    Set ts = fso.OpenTextFile(filename, 1, True): txt = ts.ReadAll: ts.Close
 
    HeaderRow$ = Split(txt, Delimiter$, 2)(0) & Delimiter$    ' берем первую строку из файла как заголовок
    txt = Split(txt, Delimiter$, 2)(1)    ' остаток текста - без строки заголовка

    ' удаляем разделители строк в конце текстовой строки (если таковые присутствуют)
    While txt Like "*" & Delimiter$: txt = Left(txt, Len(txt) - Len(Delimiter$)): Wend
 
    ' RowsCount = UBound(Split(txt, Delimiter$)) + 1    ' количество текстовых строк в файле
    FileIndex& = 1    ' индекс очередного создаваемого файла

    arr = Split(txt, Delimiter$): rc = 0: Set SplitTextFile = New Collection
    For i = LBound(arr) To UBound(arr)
        rc = rc + 1
        NewTXT$ = NewTXT$ & arr(i) & Delimiter$
        If rc >= MaxRowsCount& Or i = UBound(arr) Then    ' набрали достаточно строк для записи в файл
            NewFilename$ = Mid(filename$, 1, Len(filename$) - Len(ext$)) & "(" & FileIndex & ")" & ext$
            Set ts = fso.CreateTextFile(NewFilename$, True)
            ts.Write HeaderRow$ & NewTXT$: ts.Close
            SplitTextFile.Add NewFilename$
            FileIndex& = FileIndex& + 1
            rc = 0: NewTXT$ = ""
        End If
    Next i
    Set ts = Nothing: Set fso = Nothing
    If DeleteSourceFile Then Kill filename$    ' удаляем исходный файл, если DeleteSourceFile = TRUE
End Function