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

Листинг 2.10. Импорт большого количества данных

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