В этом уроке я покажу Вам самые популярные макросы в 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

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

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

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

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

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

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

Sub HighlightCommentCells()
    Selection.SpecialCells(xlCellTypeComments).Select
    Selection.Style= "Note"
End Sub

 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. Создание сводной таблицы

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

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

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

 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

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

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