Информатика. Книга 7 Быстрое размножение рабочей книги 7 Сохранение рабочей книги с именем, представляющим собой текущую дату 7

• Название: Книга 7 Быстрое размножение рабочей книги 7 Сохранение рабочей книги с именем, представляющим собой текущую дату 7
• Анкор: Информатика
• Дата: 16.05.2022
• Размер: 1.27 Mb.
• Имя файла: VBA_v_primerakh.doc
• Тип: Книга; #532661
• страница: 2 из 21

Глава 2. Рабочая область Microsoft Excel

Рабочая книга

Быстрое размножение рабочей книги

Листинг 2.1. Размножение рабочей книги

Sub DuplicateBook()

Dim avarFileNames As Variant

' Формирование массива из путей для копий книги

avarFileNames = Array("C:\" & _

ActiveWorkbook.Name, "D:\" & ActiveWorkbook.Name)

' Сохранение книги

ActiveWorkbook.SaveAs avarFileNames

End Sub

Сохранение рабочей книги с именем, представляющим собой текущую дату

Листинг 2.2. Сохранение книги с именем, представляющим собой текущую дату

Sub SaveAsDate()

Dim strDate As String

' Получение текущей даты и представление ее в формате "ддммгг"

strDate = Format(Now(), "ddmmyy")

' Сохранение книги в текущую папку под новым именем

ActiveWorkbook.SaveAs ActiveWorkbook.Path & "\" & strDate

End Sub

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

Листинг 2.3. Книга с одним листом

Sub NewOneSheetBook()

Workbooks.Add xlWBATWorksheet

End Sub

Установка и снятие защиты рабочей книги

Листинг 2.4. Защита рабочей книги

Sub Worksheet_BeforeRightClick(ByVal Target As Range, _

Cancel As Boolean)

If Target.Address = "$D$2" Then

' Установка защиты рабочей книги (с паролем "123", _

включенной защитой структуры книги и защитой расположения _

окон)

ThisWorkbook.Protect "123", True, True

' Указание не обрабатывать нажатие кнопки мыши _

в этой ячейке

Cancel = True

ElseIf Target.Address = "$E$5" Then

' Снятие защиты с книги (необходимо указать ранее установленный _

пароль)

ThisWorkbook.Unprotect "123"

Cancel = True

End If

End Sub

Листинг_2.5.'>Листинг 2.5. Запрет печати книги

Sub Workbook_BeforePrint(Cancel As Boolean)

' Установка флага в True заставляет Exсel игнорировать команду _

отправки книги на печать

Cancel = True

End Sub

Закрытие рабочей книги только при выполнении условия

Листинг 2.6. Условное закрытие книги

Sub Workbook_BeforeClose(Cancel As Boolean)

If Range("A1").Value <> "Можно закрывать" Then

' Условие закрытия не выполнено. Укажем Exсel игнорировать _

команду

Cancel = True

End If

End Sub

Быстрое удаление из рабочей книги ненужных имен

Листинг 2.7. Удаление ненужных имен

Sub EraseNames()

Dim nmName As Name

Dim strMessage As String

' Проверка наличия в книге определенных имен

If ThisWorkbook.Names.Count = 0 Then

' В книге нет определенных имен

MsgBox "Имена не определены"

Exit Sub

End If

' Просмотр всей коллекции определенных имен и удаление тех, _

которые пользователю не нужны

For Each nmName In ThisWorkbook.Names

With nmName

' Спрашиваем пользователя о необходимости удалить _

найденное имя

strMessage = "Удалить имя " & .Name & " ? " & vbCr & _

"относящееся к " & .RefersTo

If MsgBox(strMessage, vbYesNo + vbQuestion) = vbYes Then

' Имя можно удалить

.Delete

End If

End With

Next

End Sub

Сортировка листов в текущей рабочей книге

Листинг 2.8. Сортировка листов

Sub SortSheets()

Dim astrSheetNames() As String ' Массив для хранения имен листов

Dim intSheetCount As Integer

Dim i As Integer

Dim objActiveSheet As Object

' Если нет активной рабочей книги - закрыть процедуру

If ActiveWorkbook Is Nothing Then Exit Sub

' Проверка защищенности структуры рабочей книги

If ActiveWorkbook.ProtectStructure Then

' Сортировка листов защищенной рабочей книги невозможна

MsgBox "Структура книги " & ActiveWorkbook.Name & _

" защищена. Сортировка листов невозможна.", _

vbCritical

Exit Sub

End If

' Сохраняем ссылку на активный лист книги

Set objActiveSheet = ActiveSheet

' Отключение сочетания клавиш Ctrl+Pause Break

Application.EnableCancelKey = xlDisabled

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

Application.ScreenUpdating = False

intSheetCount = ActiveWorkbook.Sheets.Count

' Заполнение массива astrSheetNames именами листов книги

ReDim astrSheetNames(1 To intSheetCount)

For i = 1 To intSheetCount

astrSheetNames(i) = ActiveWorkbook.Sheets(i).Name

Next i

' Сортировка массива имен в порядке возрастания

Call Sort(astrSheetNames)

' Перемещение листов книги

For i = 1 To intSheetCount

ActiveWorkbook.Sheets(astrSheetNames(i)).Move _

ActiveWorkbook.Sheets(i)

Next i

' Переход на исходный рабочий лист

objActiveSheet.Activate

' Включение обновления экрана

Application.ScreenUpdating = True

' Включение сочетания клавиш Ctrl+Pause Break

Application.EnableCancelKey = xlInterrupt

End Sub

Sub Sort(astrNames() As String)

' Сортировка массива строк по алфавиту (в порядке возрастания)

Dim i As Integer, j As Integer

Dim strBuffer As String

Dim fBuffer As Boolean

For i = LBound(astrNames) To UBound(astrNames) - 1

For j = i + 1 To UBound(astrNames)

If astrNames(i) > astrNames(j) Then

' Меняем i-й и j-й элементы массива местами

strBuffer = astrNames(i)

astrNames(i) = astrNames(j)

astrNames(j) = strBuffer

End If

Next j

Next i

End Sub

Листинг 2.9. Список отсортированных листов

Sub SortSheets2()

Dim astrSheetNames() As String ' Массив для хранения имен листов

Dim intSheetCount As Integer

Dim i As Integer

Dim objActiveSheet As Object

' Если нет активной рабочей книги - закрыть процедуру

If ActiveWorkbook Is Nothing Then Exit Sub

' Проверка защищенности структуры рабочей книги

If ActiveWorkbook.ProtectStructure Then

' Сортировка листов защищенной рабочей книги невозможна

MsgBox "Структура книги " & ActiveWorkbook.Name & _

" защищена. Сортировка листов невозможна.", _

vbCritical

Exit Sub

End If

' Сохраняем ссылку на активный лист книги

Set objActiveSheet = ActiveSheet

' Отключение сочетания клавиш Ctrl+Pause Break

Application.EnableCancelKey = xlDisabled

' Функция обновления экрана отключается

Application.ScreenUpdating = False

With ActiveWorkbook

' Cоздаем новый лист "Сортировка" (если он еще не создан)

On Error Resume Next

If .Sheets("Сортировка") Is Nothing Then

.Sheets.Add.Name = "Сортировка"

End If

On Error GoTo 0

' Размещение данных на листе "Сортировка" (в столбец "A")

intSheetCount = .Sheets.Count

For i = 1 To intSheetCount

.Sheets("Сортировка").Cells(i, 1) = .Sheets(i).Name

Next i

' Сортировка данных в ячейках листа "Сортировка" по содержимому _

столбца A

.Sheets("Сортировка").Range("A1").Sort _

Key1:=.Sheets("Сортировка").Range("A1"), _

Order1:=xlAscending

' Заполнение массива имен отсортированными строками

ReDim astrSheetNames(1 To intSheetCount)

For i = 1 To intSheetCount

astrSheetNames(i) = .Sheets("Сортировка").Cells(i, 1)

Next i

' Перемещение листов

For i = 1 To intSheetCount

.Sheets(astrSheetNames(i)).Move .Sheets(i)

Next i

End With

' Переход на исходный рабочий лист

objActiveSheet.Activate

' Включаем обновление экрана

Application.ScreenUpdating = True

' Включение сочетания клавиш Ctrl+Pause Break

Application.EnableCancelKey = xlInterrupt

End Sub

Импорт данных, для которых нужно более 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