MyTetra Share
Делитесь знаниями!
Сохранить файл в текст
16.03.2019
23:43
Текстовые метки: Text, Txt
Раздел: !Закладки - VBA

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

' "I:\0ru_di\Peinture\TPM\07_QUALITE_PEINT\03_Business Objects\Просмотр списка PJI\Просмотр по списку\PJI.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

'====================================================================


Прикрепленные файлы:
Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования