14 готови макросa за Ексел

В този урок ще ви представим как бързо и лесно можете да използвате програмния език VBA (Visual Basic For Application), чрез който да разширите възможностите на Ексел и Майкрософт Офис според конкретните ви нужди и осезаемо да подобрите ефективността си при работа със софтуера. Не е необходимо да имате опит в програмирането, за да се възползвате от информацията в тази статия, но се очаква да имате основни познания по Ексел. Ако сте начинаещи, ви препоръчваме първо да прочетете статията: „11 формули на Ексел, които да започнете да използвате сега", за да се запознаете с основните функционалности на Ексел.

Подготвили сме ви няколко готови макроса с огромна функционалност, които можете да ползвате наготово, за да оптимизирате работата си. За да ги ползвате трябва само да ги инсталирате във вашия екселски файл. Следващия параграф информира читателя как се инсталира макрос в Ексел. Пропуснете тази част, ако вече знаете как се прави това.

Как се инсталира макрос?

В Ексел, натиснете клавишната комбинация alt + F11. Това ще ви отведе във VBA едитора на Ексел. После, от лявата страна натискаш с десен бутон върху папката Microsoft Excel Objects  и избираш Insert => Module. Това е мястото, където се поставят макросите. За да направите екселския файл macro-enabled трябва да го запаметите като такъв. От таба file => save as избирате save as macro-enabled workbook (с разширение .xlsm) Време е да напишем първия си макрос!

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

Това макро е много полезно, тъй като показва как може да копирате рейндж от данни във vba и как се създават и наименоват нови екселски файлове (workbooks). Можете да го надградите според нуждите ви:

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. Показване на скрити редове

Понякога Екселските файлове съдържат скрити редове за по-добра прегледност. Ето макро, което ще покаже всички редове в активния лист:

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

3. Изтриване на празни редове и колони

Празните редове в Ексел са проблем при обработката на данни. Ето как да се избавим от тях!

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. Сортиране на числа

Следното макро сортира числа от дадена колона във възходящ ред при двойно щракване. Поставете го в Sheet 1, а не в модул, за да работи:

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

6. Премахване на празни места

Понякога данните в ексел съдържат в себе си допълнителни празни места (спейсове), които могат да попречат на анализа на данни и употребата на формули. Ето макро, което премахва всички празни места между данните, които са предварително избрани с мишката:

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

7. Заменяне на празни клетки от няколко колони със стойност.

Както споменахме преди, празните клетки пречат на обработката на данни и създаването на пивот таблици. Ето код, с който празните стойности се заменят с 0. Това макро има много голямо приложение, защото можете аналогично да премахнете N/А резултати, както и да локализирате и замените други знаци като точки, запетайки, двуеточия и пр.

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

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 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

10. Автоматично изпращане на имейл с прикачен екселски файл

Любимото ми макро. Дава възможност да прикачите и изпратите файла, с който работите на предварително зададен от вас имейл адрес, заглавие на съобщението и шаблонен текст!

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 = "[email protected]; [email protected]"
    .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

11. Изпращане на всички екселски графики от един файл в 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

12. Изпращане на екселска таблица в 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

13. Изкарване на отделна дума от текст в една клетка

Можем да използваме формули, ако искаме да извадим определен брой символи. Но какво става, ако искаме да извадим само втората дума или число от текст с думи и символи в една клетка? За целта можем да създадем своя собствена функция чрез VBA, която да върши това. Нека създадем две функции: findword и findwordrev. Ето кода във vba:

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

Току що създадохме две нови функции в Ексел. Функцията =FindWordRev(A1,1) изкарва последната дума от клетка A1. Функцията =FindWord(A1,3) изкарва третата дума от клетка A1 И т.н.

14. Забрана за променяне на текста в eкселския файл

Понякога искаме да защитим данните във файла, така че само ние да можем да ги променяме. Ето как може да стане това с 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