Подборка полезных макросов VBA для Excel

Подборка полезных макросов VBA для Excel

Подборка полезных макросов VBA для Excel, которые решают частые задачи и экономят время. Все примеры готовы к использованию — просто скопируйте код в модуль (Alt + F11 → Insert → Module).

Содержание

1. Автоматическое форматирование ячеек

Задача: Подсветить строку при выборе ячейки (удобно для больших таблиц).

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' Сбрасываем цвет всех строк
    Cells.Interior.ColorIndex = xlNone
    
    ' Закрашиваем строку выбранной ячейки
    Target.EntireRow.Interior.Color = RGB(173, 216, 230)  ' Светло-голубой
End Sub

Как добавить:
Кликните правой кнопкой на ярлыке листа → View Code → вставьте код.

2. Объединение данных из нескольких листов

Задача: Собрать данные с одинаковых таблиц на разных листах в один.

Sub MergeSheets()
    Dim ws As Worksheet, destWs As Worksheet
    Dim lastRow As Long, destLastRow As Long
    
    Set destWs = ThisWorkbook.Sheets("Итог")  ' Лист для результатов
    destLastRow = destWs.Cells(destWs.Rows.Count, "A").End(xlUp).Row + 1
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> destWs.Name Then
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            ws.Range("A2:D" & lastRow).Copy destWs.Range("A" & destLastRow)
            destLastRow = destWs.Cells(destWs.Rows.Count, "A").End(xlUp).Row + 1
        End If
    Next ws
End Sub

Условие: Таблицы на всех листах имеют одинаковые колонки (A:D).

3. Удаление дубликатов по столбцу

Задача: Оставить только уникальные значения в выбранном диапазоне.

Sub RemoveDuplicatesCustom()
    Dim rng As Range
    Set rng = Selection  ' Выделите диапазон перед запуском
    
    rng.RemoveDuplicates Columns:=1, Header:=xlYes  ' 1 = проверка по первому столбцу
    MsgBox "Дубликаты удалены!", vbInformation
End Sub

4. Экспорт данных в CSV

Задача: Сохранить текущий лист в файл CSV (например, для передачи в другую систему).

Sub ExportToCSV()
    Dim ws As Worksheet, savePath As String
    Set ws = ActiveSheet
    
    savePath = Application.GetSaveAsFilename(FileFilter:="CSV Files (*.csv), *.csv")
    If savePath <> "False" Then
        ws.Copy
        ActiveWorkbook.SaveAs Filename:=savePath, FileFormat:=xlCSV
        ActiveWorkbook.Close False
        MsgBox "Файл сохранен: " & savePath, vbInformation
    End If
End Sub

5. Автоматическая отправка письма с вложением

Задача: Отправить текущую книгу по почте через Outlook.

Sub SendEmailWithAttachment()
    Dim OutlookApp As Object, MailItem As Object
    Dim recipientEmail As String, subject As String, body As String
    
    recipientEmail = "test@example.com"
    subject = "Отчет за " & Format(Date, "dd.mm.yyyy")
    body = "Данные во вложении."
    
    On Error Resume Next
    Set OutlookApp = CreateObject("Outlook.Application")
    Set MailItem = OutlookApp.CreateItem(0)
    
    With MailItem
        .To = recipientEmail
        .Subject = subject
        .Body = body
        .Attachments.Add ThisWorkbook.FullName
        .Display  ' .Send для автоматической отправки
    End With
    
    If Err.Number <> 0 Then MsgBox "Outlook не найден!", vbCritical
End Sub

Требования: Установлен Outlook.

6. Разделение текста по столбцам (аналог “Текст по столбцам”)

Задача: Разделить текст в ячейках по разделителю (например, ФИО на фамилию, имя, отчество).

Sub SplitText()
    Dim rng As Range, cell As Range
    Dim arr() As String, delimiter As String
    
    delimiter = InputBox("Введите разделитель (например, пробел или запятая):", "Разделитель")
    If delimiter = "" Then Exit Sub
    
    Set rng = Selection
    For Each cell In rng
        arr = Split(cell.Value, delimiter)
        If UBound(arr) >= 0 Then
            cell.Resize(1, UBound(arr) + 1).Value = arr
        End If
    Next cell
End Sub

7. Создание оглавления для книги

Задача: Добавить лист с гиперссылками на все листы книги.

Sub CreateTableOfContents()
    Dim ws As Worksheet, tocWs As Worksheet
    Dim i As Integer
    
    Set tocWs = ThisWorkbook.Sheets.Add(Before:=ThisWorkbook.Sheets(1))
    tocWs.Name = "Оглавление"
    
    For i = 1 To ThisWorkbook.Sheets.Count
        If ThisWorkbook.Sheets(i).Name <> "Оглавление" Then
            tocWs.Hyperlinks.Add Anchor:=tocWs.Cells(i, 1), _
                Address:="", SubAddress:="'" & ThisWorkbook.Sheets(i).Name & "'!A1", _
                TextToDisplay:=ThisWorkbook.Sheets(i).Name
        End If
    Next i
End Sub

8. Защита/снятие защиты всех листов

Задача: Быстро запаролить или разблокировать все листы.

Sub ProtectAllSheets()
    Dim ws As Worksheet, password As String
    password = InputBox("Введите пароль:", "Защита")
    
    If password = "" Then Exit Sub
    
    For Each ws In ThisWorkbook.Worksheets
        ws.Protect Password:=password
    Next ws
    MsgBox "Все листы защищены!", vbInformation
End Sub

Sub UnprotectAllSheets()
    Dim ws As Worksheet, password As String
    password = InputBox("Введите пароль:", "Снятие защиты")
    
    If password = "" Then Exit Sub
    
    For Each ws In ThisWorkbook.Worksheets
        ws.Unprotect Password:=password
    Next ws
    MsgBox "Защита снята!", vbInformation
End Sub

Как запускать макросы?

  1. Вручную: Alt + F8 → выбор макроса → Run.
  2. Кнопкой: Назначьте макрос на кнопку или графический объект (через ПКМ → Назначить макрос).
  3. По событию: Например, при открытии файла (код в ThisWorkbook → Workbook_Open).

Важно!

  • Для макросов с Selection предварительно выделите нужный диапазон.
  • Избегайте ActiveCell и ActiveSheet в сложных макросах — явно указывайте листы и диапазоны.
  • Сохраняйте файлы с макросами как .xlsm.

Эти примеры покрывают 90% рутинных задач. Для более сложных сценариев (работа с API, парсинг веб-страниц) используйте Power Query или Python + xlwings.