Импорт данных, для которых нужно более 256 столбцов

Sub ImportWideSheet()

Dim rgRange As Range              ' Хранит заполняемую ячейку

Dim lngRow As Long           ' Хранит номер текущей строки

Dim intCol As Integer        ' Хранит номер текущего столбца

Dim i As Integer

Dim strLine As String        ' Обрабатываемая строка (из файла)

Dim strCurChar As String * 1

Dim strCellValue As String   ' В этой строке формируется значение _

                                  заполняемой ячейки таблицы

Dim wshtCurrentSheet As Worksheet ' Лист, на котором находится _

                                  заполняемая ячейка

 

' Отключение обновления изображения

Application.ScreenUpdating = False

 

' Создание книги с одним листом

Workbooks.Add xlWorksheet

Set rgRange = ActiveWorkbook.Sheets(1).Range("A1")

 

' Чтение первой строки из файла (по этой строке определяется _

ширина таблицы)

Open ThisWorkbook.Path & "\Primer.txt" For Input As #1

Line Input #1, strLine

' Обработка первой строки с добавлением новых листов по мере _

необходимости

 For i = 1 To Len(strLine)

strCurChar = Mid(strLine, i, 1)

' Проверка - закончились столбцы или нет

If intCol <> 0 And intCol Mod 256 = 0 Then

    ' Столбцы текущего листа закончились - добавим новый лист _

     и перейдем к его первому столбцу

    Set wshtCurrentSheet = ActiveWorkbook.Sheets.Add(, _

     ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))

    Set rgRange = wshtCurrentSheet.Range("A1")

    intCol = 0

End If

 

' Проверка - закончилось поле или нет

If strCurChar = "," Then

    ' Запишем данные в таблицу

    rgRange.Offset(lngRow, intCol) = strCellValue

    intCol = intCol + 1

    strCellValue = ""

Else

    ' Добавляем очередной символ в строку со значением текущей _

     ячейки

    strCellValue = strCellValue & Mid(strLine, i, 1)

 

    ' Проверка - конец строки или нет

    If i = Len(strLine) Then

       ' Дошли до конца строки - запишем значение последней ячейки

       rgRange.Offset(lngRow, intCol) = strCellValue

       intCol = 0

       strCellValue = ""

    End If

End If

Next i

 

' Чтение остальных строк файла

Do Until EOF(1)

Set rgRange = ActiveWorkbook.Sheets(1).Range("A1")

lngRow = lngRow + 1

intCol = 0

Line Input #1, strLine

 

' Обработка считанной строки

For i = 1 To Len(strLine)

    strCurChar = Mid(strLine, i, 1)

    ' Проверка - закончились столбцы или нет

    If intCol <> 0 And intCol Mod 256 = 0 Then

       ' Столбцы текущего листа закончились - добавим новый лист _

        и перейдем к его первому столбцу

       Set wshtCurrentSheet = ActiveWorkbook.Sheets.Add(, _

        ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))

       Set rgRange = wshtCurrentSheet.Range("A1")

       intCol = 0

    End If

 

    ' Проверка - закончилось поле или нет

    If strCurChar = "," Then

       ' Запишем данные в таблицу

       rgRange.Offset(lngRow, intCol) = strCellValue

       intCol = intCol + 1

       strCellValue = ""

    Else

       ' Добавляем очередной символ в строку со значением текущей _

        ячейки

       strCellValue = strCellValue & Mid(strLine, i, 1)

 

       ' Проверка - конец строки или нет

       If i = Len(strLine) Then

          ' Дошли до конца строки - запишем значение последней _

           ячейки

          rgRange.Offset(lngRow, intCol) = strCellValue

          strCellValue = ""

       End If

    End If

Next i

Loop

 

' Не забываем закрыть входной файл

Close #1

' и разрешить обновление изображения

Application.ScreenUpdating = True

End Sub

 

Создание резервных копий ценных файлов

 

 Этот макрос сохраняет текущую книгу в папку C:\TEMP, добавляя к имени книги текущее время и дату.

Sub Backup_Active_Workbook()

Dim x As String

strPath = "c:\TEMP"

On Error Resume Next

x = GetAttr(strPath) And 0

If Err = 0 Then ' если путь существует - сохраняем копию книги

   strDate = Format(Now, "dd/mm/yy hh-mm")

   FileNameXls = strPath & "\" & Left(ActiveWorkbook.Name, _

        Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xls"

   ActiveWorkbook.SaveCopyAs Filename:=FileNameXls

Else 'если путь не существует - выводим сообщение

   MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical

End If

End Sub

 

При желании можно заменить первую строку на:

 

Private Sub Workbook_BeforeClose(Cancel As Boolean)

и поместить этот макрос не в Module1 как обычно, а в модуль ЭтаКнига (ThisWorkbook) - тогда автоматическое сохранение резервной копии будет происходить каждый раз перед закрытием файла.