Макрос создания текстовых файлов по данным из первого столбца

Sub СозданиеТекстовыхФайлов()
    On Error Resume Next: Dim cell As Range, ra As Range
    Set FSO = CreateObject("scripting.filesystemobject")
    BaseFolder$ = ThisWorkbook.Path & "\Папка\": MkDir BaseFolder$    ' создаём  папку

    For Each cell In Range([A1], Range("A" & Rows.Count).End(xlUp)).Cells
        filename$ = BaseFolder$ & cell.Row & ".txt"
        Set ts = FSO.CreateTextFile(filename$, True, True)
        ts.Write cell.Value: ts.Close
        ChangeFileCharset filename$, "utf-8"    ' если текстовый файл нужен в другой кодировке
    Next cell
    Set ts = Nothing: Set FSO = Nothing
    CreateObject("wscript.shell").Run "explorer.exe /e, """ & BaseFolder$ & """"    ' открываем папку с файлами
End Sub
 
Function ChangeFileCharset(ByVal filename$, ByVal DestCharset$, _
                           Optional ByVal SourceCharset$) As Boolean
    ' функция перекодировки (смены кодировки) текстового файла
    ' В качестве параметров функция получает путь filename$ к текстовому файлу,
    ' и название кодировки DestCharset$ (в которую будет переведён файл)
    ' Функция возвращает TRUE, если перекодировка прошла успешно
    On Error Resume Next: Err.Clear
    With CreateObject("ADODB.Stream")
        .Type = 2
        If Len(SourceCharset$) Then .Charset = SourceCharset$    ' указываем исходную кодировку
        .Open
        .LoadFromFile filename$    ' загружаем данные из файла
        FileContent$ = .ReadText   ' считываем текст файла в переменную FileContent$
        .Close
        .Charset = DestCharset$    ' назначаем новую кодировку
        .Open
        .WriteText FileContent$
        .SaveToFile filename$, 2   ' сохраняем файл уже в новой кодировке
        .Close
    End With
    ChangeFileCharset = Err = 0
End Function