Готовые макросы в VBA Excel, Миронов. Готовые макросы в vba excel, Миронов Глава Макросы 9
 Скачать 1.35 Mb.
|
Импорт данных, для которых нужно более 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) - тогда автоматическое сохранение резервной копии будет происходить каждый раз перед закрытием файла. |