Главная страница

Готовые макросы в vba excel, Миронов Глава Макросы 9


Скачать 1.35 Mb.
НазваниеГотовые макросы в vba excel, Миронов Глава Макросы 9
Дата06.02.2018
Размер1.35 Mb.
Формат файлаdoc
Имя файла33980_7d1642e70814394f108d07a8a2edd23e.doc
ТипДокументы
#35930
страница6 из 47
1   2   3   4   5   6   7   8   9   ...   47

Импорт данных, для которых нужно более 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) - тогда автоматическое сохранение резервной копии будет происходить каждый раз перед закрытием файла.
1   2   3   4   5   6   7   8   9   ...   47


написать администратору сайта