Sub PrepateTxt()
Dim i As Long, m
Dim iNbRow As Long, iRowStart As Long: iRowStart = 1
Dim iNbCol As Long, iClnStart As Long: iClnStart = 1
Dim oSh As Worksheet: Set oSh = ActiveSheet
Dim oWb As Workbook 'книга для сохранения в текстовый формат
Dim oWbMain As Workbook: Set oWbMain = ThisWorkbook
Dim strWbMainFullName As String: strWbMainFullName = oWbMain.FullName
Dim strWbMainName As String
'm = Split(strWbMainFullName, ".", -1, vbTextCompare)
'strWbMainName = m(LBound(m))
strWbMainName = Trim(oSh.Cells(iRowStart, 1).value) 'имя книги из шапки таблицы
EventsChange False
Удалить_дубликаты = FnDelDub(oSh, iRowStart, iClnStart)
With oSh
'удалить пустые строки
iNbCol = iClnStart 'Cells(1, 256).End(xlToLeft).Column
iNbRow = .Columns(1).Rows(65536).End(xlUp).Row
For i = iNbRow To 1 Step -1
If Len(Trim(.Cells(i, 1))) = 0 Then Rows(i).Delete
Next i
'копируем лист в новую книгу ' Sheets("1").Copy
.Copy
End With 'oSh
Set oWb = ActiveWorkbook
Сохранить_в_текст = FnSaveAsText(oWbMain.Path & "\" & strWbMainName, oWb)
EventsChange True
End Sub
'
'====================================================================
'--------------------------------------------------------------------
'Сохранить книгу в текст
'--------------------------------------------------------------------
'strFullName - путь для сохранения
'oWb - книга для сохранения
Function FnSaveAsText(ByVal strFullName As String, _
ByVal oWb As Workbook) As Boolean
' "<path_to_folder_or_file>.txt"
strFullName = strFullName & ".txt"
'Kill strFullName
On Error GoTo FnSaveAsText_Err
' ActiveWorkbook
oWb.SaveAs Filename:= _
strFullName _
, FileFormat:=xlText, CreateBackup:=False
oWb.Close
FnSaveAsText = True: Exit Function
FnSaveAsText_Err:
FnSaveAsText = False
End Function
'====================================================================
'--------------------------------------------------------------------
'Удалить дубликаты
'--------------------------------------------------------------------
'strFullName - путь для сохранения
'oWb - книга для сохранения
Function FnDelDub(ByVal oSh As Worksheet, _
Optional ByVal iRowStart As Long = 1, _
Optional ByVal iClnStart As Long = 1) As Boolean
Dim aColsArr(), i&
Dim iNbRow As Long, iNbCln As Long
Dim strCellSelect
On Error GoTo FnDelDub_Err
With oSh
iNbCln = 1 '.Cells(1, 256).End(xlToLeft).Column
iNbRow = .Cells(Rows.Count, 1).End(xlUp).Row
strCellSelect = Range(.Cells(iRowStart, iClnStart), .Cells(iNbRow, iNbCln)).Address
ReDim aColsArr(iNbCln - 1)
For i = 1 To iNbCln
aColsArr(i - 1) = i
Next
.Range(strCellSelect).RemoveDuplicates (aColsArr), xlYes
End With
Erase aColsArr
FnDelDub = True: Exit Function
FnDelDub_Err:
FnDelDub = False
End Function
'====================================================================
'====================================================================
'--------------------------------------------------------------------
'Отключить/включить события
'--------------------------------------------------------------------
Sub EventsChange(value As Boolean)
With Application
' .Calculation = xlCalculationAutomatic
.ScreenUpdating = value
.ShowWindowsInTaskbar = value
.DisplayAlerts = value
.EnableEvents = value
If value Then
.Calculation = xlCalculationAutomatic
Else: .Calculation = xlCalculationManual
End If
End With
End Sub
'Sub Убрать()
' EventsChange False
'End Sub
'
Sub Восстановить()
EventsChange True
End Sub
'====================================================================
