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

• Название: Готовые макросы в vba excel, Миронов Глава Макросы 9
• Дата: 23.01.2019
• Размер: 1.35 Mb.
• Имя файла: Готовые макросы в VBA Excel, Миронов.doc
• Тип: Документы; #64865
• страница: 11 из 47

Поиск максимального значения на всех листах книги

Function dhMaxInBook(cell As Range) As Double

Dim sheet As Worksheet

Dim dblMax As Double

Dim dblResult As Double

Dim fFirst As Boolean

fFirst = True

' Расчет максимальных значений на всех листах рабочей книги _

и выбор наибольшего из них

For Each sheet In cell.Parent.Parent.Worksheets

' Расчет максимального значения на листе

dblResult = Application.WorksheetFunction.Max(sheet.UsedRange)

If fFirst Then

' Найдено первое значение - его не с чем сравнивать

dblMax = dblResult

fFirst = False

End If

' Выбираем большее из dblMax и dbmResult

If dblResult > dblMax Then

dblMax = dblResult

End If

Next sheet

' Возврат результата

dhMaxInBook = dblMax

End Function

Рабочий лист

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

Sub IsSheetProtected()

' Проверка, установлена ли защита на содержимое листа

If Worksheets(1).ProtectContents Then

MsgBox "Защита листа включена"

Else

MsgBox "Защита листа не включена"

End If

End Sub

Список отсортированных листов

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

Создать новый лист_1

Sub NewSheet()

Worksheets.Add

End Sub

‘Sub Tes2t()

‘With Application.Workbooks.Item(ActiveWorkbook.Name)

‘Sheets.Add

‘End With

‘End Sub

‘Dim ExNew As Worksheet

‘Set ExNew = ActiveWorkbook.Worksheets.Add

‘ExNew.Name = "Имя Листа"

Создать новый лист_2

Worksheets.Add.Name = "List12345.xls"

Удаление листов в зависимости от даты

' Function DelSheetByDate

' Удаляет рабочий лист sSheetName в активной рабочей книге,

' если дата dDelDate уже наступила

' В случае успеха возвращает True, иначе - False

Public Function DelSheetByDate(sSheetName As String, _

dDelDate As Date) As Boolean

On Error GoTo errHandle

DelSheetByDate = False

' Проверка даты

If dDelDate <= Date Then

' Не выводить подтверждение на удаление

Application.DisplayAlerts = False

ActiveWorkbook.Worksheets(sSheetName).Delete

DelSheetByDate = True

Application.DisplayAlerts = True

End If

Exit Function

errHandle:

MsgBox Err.Description, vbCritical, "Ошибка №" & Err.Number

End Function