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

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

Копирование листа в книге

Sub Test()

With Application.Workbooks.Item("Test.xls")

Sheets("Test").Copy , after:=Sheets("Лист3")

End With

End Sub

Копирование листа в новую книгу (создается)

Sub Test()

With Application.Workbooks.Item("Test.xls")

Sheets("Test").Copy

End With

End Sub

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

Sub Test()

With Application.Workbooks.Item("Test.xls")

Sheets("Test").Move , after:=Sheets("Лист3")

End With

End Sub

Перемещение нескольких листов в новую книгу

Sheets(Array("Лист1", "Лист2", "Лист3")).Select

Sheets("Лист3").Activate

Sheets(Array("Лист1", "Лист2", "Лист3")).Copy

Заменить существующий файл

Sub copy_sheet()

ShName = ActiveSheet.Name

Sheets(ShName).Copy

ActiveWorkbook.SaveAs "c:\" & ShName & ".xls"

End Sub

Чтобы не вылезало диалоговое окно надо добавить

Application.DisplayAlerts = False ' вылючаем все предупреждения

ActiveWorkbook.SaveAs "c:\" & ShName & ".xls"

Application.DisplayAlerts = True 'обратно включаем предупреждения.

«Перелистывание» книги

Sub SheetsOfBook()

Dim sheet As Object

' Отображение имен всех листов активной рабочей книги

For Each sheet In ActiveWorkbook.Sheets

MsgBox (sheet.Name)

Next

End Sub

Вставка колонтитула с именем книги, листа и текущей датой

Sub AddPageHeader()

Dim i As Integer

With ThisWorkbook

' Вставка колонтитулов на все листы рабочей книги

For i = 1 To .Worksheets.Count - 1

.Worksheets(i).PageSetup.LeftHeader = .FullName

.Worksheets(i).PageSetup.CenterHeader = Worksheets(i).Name

.Worksheets(i).PageSetup.RightHeader = Now()

Next

End With

End Sub

Существует ли лист

Function dhSheetExist(strSheetName As String) As Boolean

Dim objSheet As Object

On Error GoTo HandleError ' При ошибке перейти на HandleError

' Пытаемся получить ссылку на заданный лист

objSheet = ActiveWorkbook.Sheets(strSheetName)

' Ошибки не возникло - лист существует

dhSheetExist = True

Exit Function

HandleError:

' При попытке получить доступ к листу с заданным именем _

возникла ошибка, значит, такого листа не существует

dhSheetExist = False

End Function