Небольшие, но крайне полезные макросы Excel

Макрос для выделения на каждом листе в активной книге ячейки А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]

Оставьте комментарий

Этот сайт использует Akismet для борьбы со спамом. Узнайте, как обрабатываются ваши данные комментариев.