18 готовых макросов VBA Excel

Categories: Excel, VBA

В этом уроке я покажу Вам самые популярные макросы в VBA Excel, которые вы сможете использовать для оптимизации своей работы. VBA - это язык программирования, который может использоваться для расширения возможностей MS Excel и других приложений MS Office. Это чрезвычайно полезно для пользователей MS Excel, поскольку VBA может использоваться для автоматизации вашей работы и значительно увеличить Вашу эффективность. В этой статье Вы познакомитесь с VBA и я вам покажу некоторые из наиболее полезных, готовых к использованию примеров VBA. Вы сможете использовать эти примеры для создания собственных скриптов, соответствующих Вашим потребностям.

Вам не нужен опыт программирования, чтобы воспользоваться информаций из этой статьи, но вы должны иметь базовые знания Excel. Если вы еще учитесь работать с Excel, я бы рекомендовал Вам прочитать статью 20 формул Excel, которые вам нeобходимо выучить сейчас, чтобы узнать больше о функциональных возможностях Excel.

Я подготовил для вас несколько самых полезных примеров VBA Excel с большой функциональностью, которую вы сможете использовать для оптимизации своей работы. Чтобы их использовать, вам необходимо записать их в файл. Следующий параграф посвящен установке макроса Excel. Пропустите эту часть, если вы уже знакомы с этим.

Как включить макросы в Excel

В Excel нажмите комбинацию клавиш alt + F11. Это приведет вас к редактору VBA в MS Excel. Затем щелкните правой кнопкой мыши папку Microsoft Excel Objects слева и выберите Insert => Module. Это место, где сохраняются макросы. Чтобы использовать макрос, вам нужно сохранить документ Excel как макрос. Из табуляции File => Save as, выберите Save as macro-enabled Workbok (расширение .xlsm) Теперь пришло время написать свой первый макрос!

1. Копирование данных из одного файла в другой.

Очень полезный макрос, поскольку он показывает, как скопировать ряд данных изнутри vba и как создать и назвать новую книгу. Вы можете изменить этот макрос в соответствии с вашими собственными требованиями:

Sub CopyFiletoAnotherWorkbook()
    'Copy the data
        Sheets("Example 1").Range("B4:C15").Copy
    'Create a new workbook
        Workbooks.Add
    'Paste the data
        ActiveSheet.Paste
    'Turn off application alerts
        Application.DisplayAlerts = False
    'Save the newly file. Change the name of the directory.
        ActiveWorkbook.SaveAs Filename:="C:\Temp\MyNewBook.xlsx"
    'Turn application alerts back on
        Application.DisplayAlerts = True
End Sub

2. Отображение скрытых строк

Иногда большие файлы Excel можно содержать скрытые строки для большей ясности И для лучшего удобства пользователей. Вот один макрос, который отобразит все строки из активной рабочей таблицы:

Sub ShowHiddenRows()
    Columns.EntireColumn.Hidden = False
    Rows.EntireRow.Hidden = False
End Sub

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

Пустые строки в Excel - может быть проблемой для обработки данных. Вот как избавиться от них:

Sub DeleteEmptyRowsAndColumns()
    'Declare your variables.
        Dim MyRange As Range
        Dim iCounter As Long
    'Define the target Range.
        Set MyRange = ActiveSheet.UsedRange
        'Start reverse looping through the range of Rows.
        For iCounter = MyRange.Rows.Count To 1 Step -1
    'If entire row is empty then delete it.
           If Application.CountA(Rows(iCounter).EntireRow) = 0 Then
               Rows(iCounter).Delete
               'Remove comment to See which are the empty rows
               'MsgBox "row " & iCounter & " is empty"
           End If
    'Increment the counter down
        Next iCounter
    'Step 6:  Start reverse looping through the range of Columns.
        For iCounter = MyRange.Columns.Count To 1 Step -1
    'Step 7: If entire column is empty then delete it.
               If Application.CountA(Columns(iCounter).EntireColumn) = 0 Then
                Columns(iCounter).Delete
               End If
    'Step 8: Increment the counter down
        Next iCounter      
End Sub

4. Нахождение пустых ячеек

Sub FindEmptyCell()
    ActiveCell.Offset(1, 0).Select
       Do While Not IsEmpty(ActiveCell)
          ActiveCell.Offset(1, 0).Select
       Loop
End Sub
#### 5. Заполнение пустых ячеек Как упоминалось ранее, пустые ячейки препятствуют обработке данных и созданию сводных таблиц. Вот один примерный код, который заменяет все пустые ячейки на 0. Этот макрос имеет очень большое приложение, потому что Вы можете использовать его для поиска и замены результатов N/A, а также других символов, таких как точки, запятые или повторяющиеся значения:
Sub FindAndReplace()
    'Declare your variables
        Dim MyRange As Range
        Dim MyCell As Range
    'Save the Workbook before changing cells?
        Select Case MsgBox("Can't Undo this action.  " & _
                            "Save Workbook First?", vbYesNoCancel)
            Case Is = vbYes
            ThisWorkbook.Save
            Case Is = vbCancel
            Exit Sub
        End Select
    'Define the target Range.
        Set MyRange = Selection
    'Start looping through the range.
        For Each MyCell In MyRange
    'Check for zero length then add 0.
            If Len(MyCell.Value) = 0 Then
                MyCell = 0
            End If
    'Get the next cell in the range
        Next MyCell
End Sub
#### 6. Сортировка данных Следующий макрос сортирует по возрастанию все числа из столбца активной ячейки. Просто дважды нажмите любую ячейку из столбца, который вы хотите отсортировать. NB: Здесь нам нужно поставить этот код в Sheet1 (папка Microsoft Excel Objects), а не в Module1 (папка Modules):
Private Sub Worksheet_BeforeDoubleClick (ByVal Target as Range, Cancel As Boolean)
    'Declare your Variables
        Dim LastRow As Long
    'Find last row
        LastRow = Cells (Rows.Count, 1) .End (xlUp) .Row
    'Sort ascending on double-clicked column
        Rows ("6:" & LastRow) .Sort _
        Key1: = Cells (6, ActiveCell.Column), _
        Order1: = xlAscending
End Sub
#### 7. Удаление пустых пространств Иногда данные в книге содержат дополнительные пробелы (whitespace charachters), которые могут мешать анализу данных и коррумпировать формулы. Вот один макрос, который удалит все пробелы из предварительно выбранного диапазона ячеек:
Sub TrimTheSpaces()
    'Declare your variables
        Dim MyRange As Range
        Dim MyCell As Range
    'Save the Workbook before changing cells
        Select Case MsgBox("Can't Undo this action.  " & _
                            "Save Workbook First?", vbYesNoCancel)
            Case Is = vbYes
            ThisWorkbook.Save
            Case Is = vbCancel
            Exit Sub
        End Select
    'Define the target Range.
        Set MyRange = Selection
    'Start looping through the range.
        For Each MyCell In MyRange
    'Trim the Spaces.
            If Not IsEmpty(MyCell) Then
                MyCell = Trim(MyCell)
            End If
    'Get the next cell in the range
        Next MyCell
End Sub
#### 8. Выделение дубликатов цветом Иногда в нескольких столбцах, которые мы хотели бы осветить, есть повторяющиеся значения. Этот макрос делает именно это:
Sub HighlightDuplicates()
    'Declare your variables
        Dim MyRange As Range
        Dim MyCell As Range
    'Define the target Range.
        Set MyRange = Selection 
    'Start looping through the range.
        For Each MyCell In MyRange 
    'Ensure the cell has Text formatting.
            If WorksheetFunction.CountIf(MyRange, MyCell.Value) > 1 Then
                MyCell.Interior.ColorIndex = 36
            End If
    'Get the next cell in the range
        Next MyCell
End Sub
#### 9. Выделение десяти самых высоких чисел
Этот код будет отображать десять самых высоких чисел из набора ячеек:
Sub TopTen()
    Selection.FormatConditions.AddTop10
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
        With Selection.FormatConditions(1)
            .TopBottom = xlTop10Top
            'Change the rank here to highlight a different number of values
            .Rank = 10
            .Percent = False
        End With
        With Selection.FormatConditions(1).Font
            .Color = -16752384
            .TintAndShade = 0
        End With
        With Selection.FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 13561798
            .TintAndShade = 0
        End With
    Selection.FormatConditions(1).StopIfTrue = False
End Sub
Вы можете легко настроить код, чтобы выделить различное количество чисел. #### 10. Выделение данных больших чем данные число Когда вы запустите этот код, появится окно. Вам надо написать число, которое вы хотите сравнить с выбранными ячейками.
Sub HighlightGreaterThanValues()
    Dim i As Integer
    i = InputBox("Enter Greater Than Value", "Enter Value")
    Selection.FormatConditions.Delete
    'Change the Operator to xlLower to highlight lower than values
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:=i
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
        With Selection.FormatConditions(1)
            .Font.Color = RGB(0, 0, 0)
            .Interior.Color = RGB(31, 218, 154)
        End With
End Sub
Вы тоже можете настроить этот код, чтобы выделить более низкие чисел. #### 11. Выделение ячеек комментариями Простой макрос, который выделяет все ячейки, содержащие комментарии:
Sub HighlightCommentCells()
    Selection.SpecialCells(xlCellTypeComments).Select
    Selection.Style= "Note"
End Sub
#### 12. Выделение ячеек со словами с ошибками Это очень полезно, когда вы работаете с функциями, которые принимают строки, однако кто-то ввел строку с ошибкой, и ваши формулы не работают. Вот как решить эту проблему:
 Sub ColorMispelledCells()
    For Each cl In ActiveSheet.UsedRange
        If Not Application.CheckSpelling(Word:=cl.Text) Then _
        cl.Interior.ColorIndex = 28
    Next cl
End Sub

13. Создание сводной таблицы

Вот как создать сводную таблицу в MS Excel (версия 2007). Особенно полезно, когда вы делаете индивидуальный отчет каждый день. Вы можете оптимизировать создание сводной таблицы следующим образом:

Sub PivotTableForExcel2007()
    Dim SourceRange As Range
    Set SourceRange = Sheets("Sheet1").Range("A3:N86")
    ActiveWorkbook.PivotCaches.Create( _
    SourceType:=xlDatabase, _
    SourceData:=SourceRange, _
    Version:=xlPivotTableVersion12).CreatePivotTable _
    TableDestination:="", _
    TableName:="", _
    DefaultVersion:=xlPivotTableVersion12
End Sub

14. Отправка активного файла по электронной почте

Мой любимый код VBA. Он позволяет вам прикреплять и отправлять файл, с которым вы работаете, с предопределенным адресом электронной почты, заголовком сообщения и телом сообщения! Сначала Вам нужно сделать референцию в Excel на Microsoft Outlook (в редакторе Excel VBA, нажмите tools => references и выберите Microsoft Outlook).

Sub SendFIleAsAttachment()
    'Declare your variables
    'Set reference to Microsoft Outlook Object library
        Dim OLApp As Outlook.Application
        Dim OLMail As Object
    'Open Outlook start a new mail item
        Set OLApp = New Outlook.Application
        Set OLMail = OLApp.CreateItem(0)
        OLApp.Session.Logon  
    'Build your mail item and send
        With OLMail
        .To = "admin@datapigtechnologies.com; mike@datapigtechnologies.com"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = "Hi there"
        .Attachments.Add ActiveWorkbook.FullName
        .Display  'Change to .Send to send without reviewing
        End With
    'Memory cleanup
        Set OLMail = Nothing
        Set OLApp = Nothing
End Sub

15. Вставка всех графиков Excel в презентацию PowerPoint

Очень удобный макрос, который позволяет вам добавлять все ваши графики Excel в презентацию Powerpoint одним щелчком мыши:

Sub SendExcelFiguresToPowerPoint()
    'Set reference to Microsoft Powerpoint Object Library
    'Declare your variables
        Dim PP As PowerPoint.Application
        Dim PPPres As PowerPoint.Presentation
        Dim PPSlide As PowerPoint.Slide
        Dim i As Integer
    'Check for charts; exit if no charts exist
        Sheets("Slide Data").Select
            If ActiveSheet.ChartObjects.Count < 1 Then
                MsgBox "No charts existing the active sheet"
                Exit Sub
            End If
    'Open PowerPoint and create new presentation
        Set PP = New PowerPoint.Application
        Set PPPres = PP.Presentations.Add
        PP.Visible = True
    'Start the loop based on chart count
            For i = 1 To ActiveSheet.ChartObjects.Count
            'Copy the chart as a picture
                ActiveSheet.ChartObjects(i).Chart.CopyPicture _
                Size:=xlScreen, Format:=xlPicture
                Application.Wait (Now + TimeValue("0:00:1"))
            'Count slides and add new slide as next available slide number
                ppSlideCount = PPPres.Slides.Count
                Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
                PPSlide.Select
            'Paste the picture and adjust its position; Go to next chart
                PPSlide.Shapes.Paste.Select
                PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
                PP.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
            Next i
    'Memory Cleanup
        Set PPSlide = Nothing
        Set PPPres = Nothing
        Set PP = Nothing
End Sub

16. Вставка таблицы Excel в MS Word

Таблицы Excel обычно помещаются внутри текстовых документов. Вот один автоматический способ экспорта таблицы Excel в MS Word:

 Sub ExcelTableInWord()
    'Set reference to Microsoft Word Object library
    'Declare your variables
        Dim MyRange As Excel.Range
        Dim wd As Word.Application
        Dim wdDoc As Word.Document
        Dim WdRange As Word.Range
    'Copy the defined range
       Sheets("Revenue Table").Range("B4:F10").Cop
    'Open the target Word document
        Set wd = New Word.Application
        Set wdDoc = wd.Documents.Open _
        (ThisWorkbook.Path & "\" & "PasteTable.docx")
        wd.Visible = True
    'Set focus on the target bookmark
        Set WdRange = wdDoc.Bookmarks("DataTableHere").Rangе
    'Delete the old table and paste new
        On Error Resume Next
        WdRange.Tables(1).Delete
        WdRange.Paste 'paste in the table   
    'Adjust column widths
        WdRange.Tables(1).Columns.SetWidth _
        (MyRange.Width / MyRange.Columns.Count), wdAdjustSameWidth
    'Reinsert the bookmark
        wdDoc.Bookmarks.Add "DataTableHere", WdRange
    'Memory cleanup
        Set wd = Nothing
        Set wdDoc = Nothing
        Set WdRange = Nothing
End Sub

17. Извлечение слов из текста

Мы можем использовать формулы, если хотим извлечь определенное количество символов. Но что, если мы хотим извлечь только одно слово из предложения или диапазон слов в ячейке? Для этого мы можем сами создать функцию Excel с помощью VBA. Это одна из самых удобных функций VBA, поскольку она позволяет создавать собственные формулы, которые отсутствуют в MS Excel. Давайте продолжим и создадим две функции: findword() и findwordrev():

Function FindWord(Source As String, Position As Integer) As String
     On Error Resume Next
     FindWord = Split(WorksheetFunction.Trim(Source), " ")(Position - 1)
     On Error GoTo 0
End Function

Function FindWordRev(Source As String, Position As Integer) As String
     Dim Arr() As String
     Arr = VBA.Split(WorksheetFunction.Trim(Source), " ")
     On Error Resume Next
     FindWordRev = Arr(UBound(Arr) - Position + 1)
     On Error GoTo 0
End Function

Отлично, мы уже создали две новые функции в Excel! Теперь попробуйте использовать их в Excel. Функция = FindWordRev (A1,1) берет последнее слово из ячейки A1. Функция = FindWord (A1,3) берет третье слово из ячейки A1 и т. Д.

18. Защита данных в MS Excel

Иногда мы хотим защитить данных нашего файла, чтобы только мы могли его изменять. Вот как это сделать с VBA:

Sub ProtectSheets()
    'Declare your variables
        Dim ws As Worksheet
    'Start looping through all worksheets
        For Each ws In ActiveWorkbook.Worksheets
    'Protect and loop to next worksheet
        ws.Protect Password:="1234"
        Next ws
End Sub

Поздравления! Поскольку вы все еще читаете это, вы действительно заинтересованы в изучении VBA. Как вы уже сами видели, язык программирования VBA чрезвычайно полезен и может сэкономить нам много времени. Надеюсь, вы нашли эту информацию полезной и использовали ее, чтобы стать мастером MS Excel, VBA и компьютерных наук в целом.

© 2018 Атанас Йонков


Литература:
1. ExcelChamps.com: Top 100 Useful Excel Macro [VBA] Codes Examples.
2. Michael Alexander, John Walkenbach (2012). 101 Ready-To-Use Excel Macros.
3. BG Excel.info: 14 ready-to-use Macros for Excel.