Option Explicit
'Автор Б. Виталий В. (bvv, bedvit)
'Макрос записан: 26/09/2018 (bvv)
'Редакция: 5 от 05/05/2019
'Действие:
'Сохраняет все листы книги, перебирая
'Сохраняет лист Excel в текстовом формате *txt (csv), в кодировке ANSI, с нужным разделителем - запятая или точка с запятой.
'Строки содержащие символ разделителя и пробел - берутся в кавычки.
'*.txt сохраняется в директорию с исходным файлом.
'Имя файла = имя листа.
'Форматы числа и даты сохраняются в исходном форматировании, без преобразований.
'удаляются Columns("A:T")
Sub save_as_txt()
Dim NameTemp As String, ac, WS As Worksheet, Р_Т_З As Boolean
Dim cRow As Long, cColumn As Long, rEnd As Long, rEndMax As Long, cEndMax As Long, cEnd As Long, arr, s, char, SheetName As String, ЗапрещённыеСимволы, keyDell
Р_Т_З = True 'если нужен разделитель "точка с запятой", то True, если "запятая" - False
If ActiveWorkbook.Path = "" Then MsgBox "BVV: Для выполнения этой команды нужно, чтобы исходный файл был сохранен.", vbExclamation: Exit Sub
With Application: .StatusBar = "BVV: обработка данных...": .ScreenUpdating = 0: .DisplayAlerts = 0: .EnableEvents = 0: ac = .Calculation: .Calculation = -4135: End With
For Each WS In ActiveWorkbook.Worksheets 'цикл по листам
SheetName = WS.Name
''''''''удалим запрещенные символы файловой системы
ЗапрещённыеСимволы = Array("\", "/", ":", "*", "?", "<", ">", "|", Chr(34)) 'кавычки
For Each char In ЗапрещённыеСимволы
SheetName = Replace(SheetName, char, "_")
Next ' char
'''''''''''''''''''''''''''''''''''''''''''''''''''
NameTemp = Mid$(ActiveWorkbook.FullName, 1, Len(ActiveWorkbook.FullName) - 5) & "(" & SheetName & ")" & ".txt"
WS.Copy
Cells.Copy
Cells.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Columns("A:T").Delete
'сохраняем в значениях
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ActiveSheet.UsedRange.Select
If Selection.Count = 1 Then
Selection.Resize(1, 2).Select ' добавляем ячейку для правильного формирования массива
arr = Selection 'Intersect(ActiveSheet.UsedRange, Selection)
ReDim Preserve arr(1 To 1, 1 To 1) ' удаляем лишнюю ячейку
Else
arr = Selection 'Intersect(ActiveSheet.UsedRange, Selection)
End If
keyDell = Chr(16) & Chr(19) & IIf(Р_Т_З, ";", ",") & Chr(127) & Chr(23) ' ключ с разделителем для взятия пробелов в кавычки в дальнейшем удаляем
rEnd = UBound(arr)
cEnd = UBound(arr, 2)
rEndMax = 0
cEndMax = 0
For cRow = 1 To rEnd
For cColumn = 1 To cEnd
If IsError(arr(cRow, cColumn)) Then 'выводим ошибки в текстовый файл не обрабатывая
rEndMax = Application.Max(cRow, rEndMax)
cEndMax = Application.Max(cColumn, cEndMax)
ElseIf Not arr(cRow, cColumn) = "" Or Not IsEmpty(arr(cRow, cColumn)) Then
If InStr(1, arr(cRow, cColumn), " ", vbTextCompare) > 0 Then
arr(cRow, cColumn) = keyDell & arr(cRow, cColumn)
Else
arr(cRow, cColumn) = "'" & arr(cRow, cColumn)
End If
rEndMax = Application.Max(cRow, rEndMax)
cEndMax = Application.Max(cColumn, cEndMax)
End If
Next
Next
ActiveSheet.Cells.Delete
ActiveSheet.Cells(1, 1).Resize(rEndMax, cEndMax) = arr
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Р_Т_З Then
ActiveWorkbook.SaveAs Filename:=NameTemp, FileFormat:=xlCSV, CreateBackup:=False, local:=True
Else
ActiveWorkbook.SaveAs Filename:=NameTemp, FileFormat:=xlCSV, CreateBackup:=False, local:=False
End If
ActiveWindow.Close False
'удаляем отметку в txt файле
Open NameTemp For Input As #1 'открываем файл на чтение
s = Input(LOF(1), 1) 'считываем в переменную
Close #1 ' закрываем
'Application.Wait (Now + 1 / 86400) ' ждем одну секунду от закрытия до открытия этого же файла.
Open NameTemp For Output As #1 'открываем для записи
Print #1, Replace(s, keyDell, "") 'заменяем текст и записываем в файл
Close #1 'закрываем файл
''''''''''''''''
Next
With Application: .ScreenUpdating = 1: .DisplayAlerts = 1: .EnableEvents = 1: .Calculation = ac: .StatusBar = False: End With
End Sub |
