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

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

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

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

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

L = 0

For Each Sheet In Worksheets

If Sheet.Name = "List12" Then

L = 1

MsgBox "List12 совпадает с расчетным листом. Переименуйте свой List12 на какое нибудь другое имя!"

End If

Next
If L = 0 Then

Worksheets.Add.Name = "List12"

Worksheets(1).Visible = True

Worksheets("List12").Visible = True

Worksheets("List12").Activate

End If

Вывод количества листов в активной книге

Sub Test()

MsgBox (Str(Application.Workbooks.Item(ActiveWorkbook.Name).Sheets.Count))

End Sub

Вывод количества листов в активной книге в виде гиперссылок

Sub SheetNamesAsHyperLinks()

Dim sheet As Worksheet

Dim cell As Range

With ActiveWorkbook

' Просмотр всех листов книги и создание гиперссылок на них _

на первом листе

For Each sheet In ActiveWorkbook.Worksheets

Set cell = Worksheets(1).Cells(sheet.Index, 1)

.Worksheets(1).Hyperlinks.Add Anchor:=cell, Address:="", _

SubAddress:="'" & sheet.Name & "'" & "!A1"

cell.Formula = sheet.Name

Next

End With

End Sub

Вывод имен активных листов по очереди

Sub Test()

With Application.Workbooks.Item(ActiveWorkbook.Name)

For x = 1 To .Sheets.Count

MsgBox (Sheets.Item(x).Name)

Next x

End With

End Sub

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

Sub ShowInfo()

Dim i As Integer

' Выводим имя файла рабочей книги

Range("A1") = ActiveWorkbook.Name

' Выводим имя текущего листа

Range("B1") = ActiveSheet.Name

' Выводим номера листов

For i = 1 To ActiveWorkbook.Sheets.Count

ActiveSheet.Cells(i, 3) = i

Next i

End Sub