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
Макрос создания текстовых файлов по данным из первого столбца |
- 1471 просмотр
Не получается применить макрос? Не удаётся изменить код под свои нужды?
Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.
Комментарии
как весь диапазон вставить
Отправить комментарий