Индивидуальные очистные сооружения: К классу индивидуальных очистных сооружений относят сооружения, пропускная способность которых...
Семя – орган полового размножения и расселения растений: наружи у семян имеется плотный покров – кожура...
Топ:
Техника безопасности при работе на пароконвектомате: К обслуживанию пароконвектомата допускаются лица, прошедшие технический минимум по эксплуатации оборудования...
Выпускная квалификационная работа: Основная часть ВКР, как правило, состоит из двух-трех глав, каждая из которых, в свою очередь...
Интересное:
Влияние предпринимательской среды на эффективное функционирование предприятия: Предпринимательская среда – это совокупность внешних и внутренних факторов, оказывающих влияние на функционирование фирмы...
Искусственное повышение поверхности территории: Варианты искусственного повышения поверхности территории необходимо выбирать на основе анализа следующих характеристик защищаемой территории...
Лечение прогрессирующих форм рака: Одним из наиболее важных достижений экспериментальной химиотерапии опухолей, начатой в 60-х и реализованной в 70-х годах, является...
Дисциплины:
2021-10-05 | 48 |
5.00
из
|
Заказать работу |
|
|
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) - тогда автоматическое сохранение резервной копии будет происходить каждый раз перед закрытием файла.
|
|
|
Кормораздатчик мобильный электрифицированный: схема и процесс работы устройства...
Эмиссия газов от очистных сооружений канализации: В последние годы внимание мирового сообщества сосредоточено на экологических проблемах...
Историки об Елизавете Петровне: Елизавета попала между двумя встречными культурными течениями, воспитывалась среди новых европейских веяний и преданий...
Общие условия выбора системы дренажа: Система дренажа выбирается в зависимости от характера защищаемого...
© cyberpedia.su 2017-2024 - Не является автором материалов. Исключительное право сохранено за автором текста.
Если вы не хотите, чтобы данный материал был у нас на сайте, перейдите по ссылке: Нарушение авторских прав. Мы поможем в написании вашей работы!