Макрос для выделения на каждом листе в активной книге ячейки А1. При этом также происходит перемещение экрана.
[code language=»vb»]
Sub A1SelectionEachSheet()
Dim i As Integer
Application.ScreenUpdating = False
For i = 1 To Sheets.Count
Sheets(i).Select
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
Range("a1").Select
Next
Sheets(1).Select
Application.ScreenUpdating = True
End Sub
[/code]
Макрос для копирования текущего листа заданное количество раз. Полезен для тестирования каких то макросов — внесли правки, проверили на копии данных. Закончились копии — запустили макрос еще раз
[code language=»vb»]
Sub SimpleCopy()
Dim i As Integer, j As Integer
i = Application.InputBox("Введите число копий текущего листа")
Application.ScreenUpdating = False
For j = 1 To i
ActiveSheet.Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Копия " & j
Next j
Application.ScreenUpdating = True
End Sub
[/code]
Создание листов с названиями из указанного диапазона на листе
[code language=»vb»]
Sub CreateFromList()
Dim cell As Range
For Each cell In Selection
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = cell.Value
Next cell
End Sub
[/code]
Маркрос отправки письма с задержкой. Доработанный макрос из книги Джона Уокенбаха Профессиональное программирование на VBA
[code language=»vb»]
Sub ОтправкаПисьма()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
On Error GoTo cleanup
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "pupkin@vasiliy.ru"
.Subject = "Отчет по продажам"
.Attachments.Add "C:\Test.txt"
.Body = "Текст письма"
.DeferredDeliveryTime = Replace(Date, ".", "/") & " 11:00:00"
.send ‘.Display для формирования письма и его открытия
End With
On Error GoTo 0
Set OutMail = Nothing
cleanup:
Set OutApp = Nothing
End Sub
[/code]
Немного доработанный макрос оглавления от Николая Павлова.
Если в книге уже существует лист «Оглавление» — макрос предлагает его удалить. Если нет — создает лист «Оглавление» и вставляет ссылки с названиями листов
[code language=»vb»]
Sub TableOfContent()
Dim sheet As Worksheet
Dim cell As Range
Dim Answer As Integer
Application.ScreenUpdating = False
With ActiveWorkbook
For Each Worksheet In ActiveWorkbook.Worksheets
If Worksheet.Name = "Оглавление" Then
Answer = MsgBox("В книге есть лист с именем Оглавление. Удалить его?", vbYesNo)
If Answer = vbNo Then Exit Sub
If Answer = vbYes Then
Application.DisplayAlerts = False
Worksheet.Delete
Application.DisplayAlerts = True
End If
End If
Next
End With
Sheets(Array(1)).Select
Sheets.Add
Sheets(1).Name = "Оглавление"
With ActiveWorkbook
For Each sheet In ActiveWorkbook.Worksheets
If sheet.Name <> "Оглавление" Then
Set cell = Worksheets(1).Cells(sheet.Index, 1)
.Worksheets(1).Hyperlinks.Add anchor:=cell, Address:="", SubAddress:="’" & sheet.Name & "’" & "!A1"
cell.Formula = sheet.Name
End If
Next sheet
End With
Rows("1:1").Delete
Application.ScreenUpdating = True
End Sub
[/code]
Сортировка листов от мастеров VBA. Макрос сортирует в том числе и скрытые листы. Не сработает, если у книги защищена структура
[code language=»vb»]
Sub СОРТИРОВАТЬ_ВСЕ_ЛИСТЫ()
Application.ScreenUpdating = False: Application.EnableEvents = False
Dim iSht As Worksheet, oDict As Object, i%, j%
Set oDict = CreateObject("Scripting.Dictionary")
‘ запомнить состояние видимости каждого из листов и сделать все видимыми
For Each iSht In ActiveWorkbook.Sheets
oDict.Item(iSht.Name) = iSht.Visible: iSht.Visible = True
Next
With ActiveWorkbook ‘ сортировка видимых листов
For i = 1 To .Sheets.Count — 1
For j = i + 1 To .Sheets.Count
If UCase(.Sheets(i).Name) > UCase(.Sheets(j).Name) Then .Sheets(j).Move Before:=.Sheets(i)
Next j
Next i
End With
‘ восстановить исходное состояние видимости каждого из листов
For Each iSht In ActiveWorkbook.Sheets
iSht.Visible = oDict.Item(iSht.Name)
Next
Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub
[/code]
Импорт столбцов «Поле1» и «Поле2» из листа «Лист1» файла Excel «C:\Manager.xls» через ADODB подключение и вставка содержимого начиная с ячейки A1 текущего листа
[code language=»vb»]
Sub ИмпортДанных()
Dim varConn As String
Dim varSQL As String
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim QT1 As QueryTable
varConn = "Data Source=C:\Manager.xls;Extended Properties=Excel 8.0;"
varSQL = "SELECT [Поле1], [Поле2] FROM [C:\Manager.xls].[Лист1$] ORDER BY [Поле2]"
Set cn = New ADODB.Connection
With cn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = varConn
.Open
End With
Set rs = CreateObject("ADODB.Recordset")
rs.Open varSQL, cn
Set QT1 = ActiveSheet.QueryTables.Add(rs, Range("A1"))
QT1.Refresh
ActiveSheet.Name = "CL"
cn.Close
Set cn = Nothing
Set rs = Nothing
End Sub
[/code]