В този урок ще ви представим как бързо и лесно можете да използвате програмния език 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
