Excel Makra VBA Příklady

Úvod

Makra jsou krátké prográmky, ve kterých je zaznamenán nějaký postup práce v Excelu.

Makra lze vytvořit

  • Nahráváním – předvedete počítači činnost, ten si jí zapamatuje a opakuje. “Slepý robot” Funguje jen pro jednoduché případy
  • Z internetu – spoustu věcí, co řešíte, vyřešil už někdo před vámi. Googlete VBA + popis toho, co chcete řešit, ideálně v angličtině. Ne všechno musí fungovat.
  • Programováním – Makro si můžete naprogramovat v jazyku Visual basic. To chce trochu cviku, ale pak zvládnete cokoli.

Makro je uloženo

  • V sešitu. V tom případě musí být uložen jako xlsm. Když je sešit s makrem otevřený, makro funguje i ve všech ostatních otevřených sešitech.
  • V osobním sešitu maker. To je neviditelný sešit na pozadí. Makro bude fungovat na vašem počítači vždy.

Makro se může spustit několika způsoby

  • Klávesovou zkratkou
  • Z menu na kartě vývojář
  • Tlačítkem na vlastní kartě
  • Tlačítkem na listě rychlého spuštění
  • Tlačítkem přímo v sešitu
  • Přímo po otevření sešitu

Zde je Tahák na makra:

Část A: Nahrávaná makra

Stáhněte si pracovní sešit a nahrajte makra podle popisu níže.

1. Hlavicka

Makro automaticky přidá na list hlavičku, která vypadá takto

2. Datafix

Upravte data na listu Zaměstnanci:

  • Odstraňte sloupce pohlaví, vzdělání a datum nástupu
  • Přebarvěte řádek záhlaví na zeleno
  • Nastavte automatickou šířku sloupců
  • Odstraňte “Kč” z formátu příjmu

3. ZelenyFormat

Nahrajte makro, které vybrané buňky zformátuje na zeleno, s ohraničením a připraví na formát EUR.

4. Nahrazeni

Nahrajte makro, které ve vybraných buňkách nahradí názvy pozic zkratkami:

  • Dělník => D
  • Technik => T
  • Administrativa => T
  • Brigádník > B

5. Odslouceni

Nahrajte makro, které zruší sloučení všech sloučených buněk na aktuálním.

Část B: Makra z Internetu

Makra z internetu zkopírujte a vložte přes Visual Basic do modulu sešitu, kde chcete aby bylo. Makra z internetu nemusí vždy fungovat! Někdy je třeba vyzkoušet více zdrojů.

1 Převedení všech vzorců na listu na hodnoty

Sub Nahodnoty()
With ActiveSheet.UsedRange
.Value = .Value
End With
End Sub

Zdroj: TrumpExcel.com

2 Odkrytí všech skrytých listů

Sub UnhideAllWorksheet()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
Next ws
End Sub

Zdroj: ExcelChamps.com

3 Zamknutí a odemknutí všech listů na heslo

Sub ZamknoutVsechnyListy()
Dim ws As Worksheet
Dim ps As String
ps = InputBox("Zadejte Heslo:", vbOKCancel)
For Each ws In ActiveWorkbook.Worksheets
ws.Protect Password:=ps
Next ws
End Sub

A druhé makro na odemknutí

Sub OdemknoutVsechnyListy()
Dim ws As Worksheet
Dim ps As String
ps = InputBox("Zadejte Heslo:", vbOKCancel)
For Each ws In ActiveWorkbook.Worksheets
ws.Unprotect Password:=ps
Next ws
End Sub

Zdroj: ExcelChamps.com

4 Seřadit všechny listy podle abecedy

Sub SeraditListyAbecedne()
Application.ScreenUpdating = False
Dim ShCount As Integer, i As Integer, j As Integer
ShCount = Sheets.Count
For i = 1 To ShCount - 1
For j = i + 1 To ShCount
If Sheets(j).Name < Sheets(i).Name Then
Sheets(j).Move before:=Sheets(i)
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub

Zdroj: TrumpExcel.com

5 Odkrýt všechny skryté řádky a sloupce

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

Zdroj: ExcelChamps.com

6 Vytvoření záložní kopie dokumentu, se kterým pracujete

Vytvoří do stejné složky kopii tohoto souboru s datumem a časem uložení

Sub Zaloha()
ActiveWorkbook.SaveCopyAs Filename:=ActiveWorkbook.Path & _
"\" & Format(Now, "yyyy-mm-dd hh-mm-ss") & " " & _
ActiveWorkbook.name
End Sub

7 Poslání aktuálního dokumentu emailem

Pokud nepoužíváte Microsoft outlook, zkuste tuto jednodušší verzi, která aktuální dokument pošle výchozím emailovým klientem. Je možné, že to nebude fungovat, zejména pokud používáte webové rozhraní pro mail.

Sub OpenWorkbookAsAttachment()
Application.Dialogs(xlDialogSendMail).Show
End Sub

Zdroj: ExcelChamps.com

Pokud máte Microsoft Outlook, použijte toto makro, které umožňuje mnohem větší možnosti, například upravit text zprávy.

Sub Send_Mail()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = "excel@jiribenedikt.com"
.Subject = "Report KPIs"
.Body = "Milý týme, posílám v příloze report za předchozí měsíc."
.Attachments.Add ActiveWorkbook.FullName
.display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Zdroj: ExcelChamps.com

8 Zpráva při otevření sešitu

Sub auto_open()
MsgBox "Dobry den. Toto je pracovni sesit ke kurzu. Vsechny detaily najdete na www.jiribenedikt.com"
End Sub
Sub auto_close()
MsgBox "Diky, bylo to fajn. Kdyby neco, napiste"
End Sub

Zdroj: ExcelChamps.com

9 Vytvoření automatického obsahu

Sub Obsah()
Dim i As Long
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Obsah").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Activeworkbook.Sheets.Add Before:=ActiveWorkbook.Worksheets(1)
ActiveSheet.Name = "Obsah"
For i = 1 To Sheets.Count
With ActiveSheet
.Hyperlinks.Add _
Anchor:=ActiveSheet.Cells(i, 1), _
Address:="", _
SubAddress:="'" & Sheets(i).Name & "'!A1", _
ScreenTip:=Sheets(i).Name, _
TextToDisplay:=Sheets(i).Name
End With
Next i
End Sub

Zdroj: ExcelChamps.com

10 Smazat všechny prázdné řádky z listu

Sub SmazatPrazdneRadky()
    Dim LastRowIndex As Integer
    Dim RowIndex As Integer
    Dim UsedRng As Range
 
    Set UsedRng = ActiveSheet.UsedRange
    LastRowIndex = UsedRng.Row - 1 + UsedRng.Rows.Count
    Application.ScreenUpdating = False
 
    For RowIndex = LastRowIndex To 1 Step -1
        If Application.CountA(Rows(RowIndex)) = 0 Then
            Rows(RowIndex).Delete
        End If
    Next RowIndex
 
    Application.ScreenUpdating = True
End Sub

Zdroj: Ablebits.com

11 Rozdělení na více listů podle jednoho sloupce

Sub RozelitNaListyPodleSloupce()
'updateby Extendoffice
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim xTRg As Range
Dim xVRg As Range
Dim xWSTRg As Worksheet
On Error Resume Next
Set xTRg = Application.InputBox("Prosím vyberte řádek s hlavičkou (nadpisy sloupců):", "Jiri Benedikt", "", Type:=8)
If TypeName(xTRg) = "Nothing" Then Exit Sub
Set xVRg = Application.InputBox("Prosím vyberte sloupec, podle kterého chcete data rozdělit:", "Jiri Benedikt", "", Type:=8)
If TypeName(xVRg) = "Nothing" Then Exit Sub
vcol = xVRg.Column
Set ws = xTRg.Worksheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = xTRg.AddressLocal
titlerow = xTRg.Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
Application.DisplayAlerts = False
If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
Else
Sheets("xTRgWs_Sheet").Delete
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
End If
Set xWSTRg = Sheets("xTRgWs_Sheet")
xTRg.Copy
xWSTRg.Paste Destination:=xWSTRg.Range("A1")
ws.Activate
For i = (titlerow + xTRg.Rows.Count) To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
xWSTRg.Range(title).Copy
Sheets(myarr(i) & "").Paste Destination:=Sheets(myarr(i) & "").Range("A1")
ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A" & (titlerow + xTRg.Rows.Count))
Sheets(myarr(i) & "").Columns.AutoFit
Next
xWSTRg.Delete
ws.AutoFilterMode = False
ws.Activate
Application.DisplayAlerts = True
End Sub

Zdroj: Extendoffice.com

12 Uložení listů do jednotlivých dokumentů

Sub UlozitPoListech()
'Updateby20140612
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ActiveWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
    xWs.Copy
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        Select Case xWb.FileFormat
            Case 51:
                FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If Application.ActiveWorkbook.HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56:
                FileExtStr = ".xls": FileFormatNum = 56
            Case Else:
                FileExtStr = ".xlsb": FileFormatNum = 50
        End Select
    End If
    xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
    Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
    Application.ActiveWorkbook.Close False
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub

Zdroj: Extendoffice.com

13 Uložit všechny listy jednotlivě jako PDF

Sub UlozitJednotlivePDF()
 
Dim ws As Worksheet
 
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & " PDF " & DateString
MkDir FolderName

For Each ws In Worksheets
ws.Select
nm = ws.Name
 
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=FolderName & "\" & nm & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
 
Next ws
 
End Sub

14 Odstranění diakritiky

Toto je vlastní funkce. K použití zadáte do buňky =BEZDIAKRITIKY( a jako její vstup zadáte text, ze kterého má odstranit diaktitiku.) V této jednoduché podobě nefunguje v osobním sešitě maker!

Function BEZDIAKRITIKY(thestring As String)
Dim A As String * 1
Dim B As String * 1
Dim i As Integer

Const AccChars = "áäčďéěíĺľňóôőöŕšťúůűüýřžÁÄČĎÉĚÍĹĽŇÓÔŐÖŔŠŤÚŮŰÜÝŘŽ"
Const RegChars = "aacdeeillnoooorstuuuuyrzAACDEEILLNOOOORSTUUUUYRZ"

For i = 1 To Len(AccChars)
    A = Mid(AccChars, i, 1)
    B = Mid(RegChars, i, 1)
    thestring = Replace(thestring, A, B)
Next

BEZDIAKRITIKY = thestring
End Function

Zdroj: Miroslavpecka.cz

15 Sloučení více listů na jeden list

Najděte si sami na internetu vhodné makro

16 Makro, které vy sami potřebujete

Zamyslete se, jakou funkci v Excelu potřebujete a dejte si na ně makro.

Část C: Programování

1 Listy – cvičné makro pro začátečníky v programování

Pro procvičení základních programovacích funkcí si vytvoříme jednoduché makro. Každá verze bude mít přidané nějaké funkce

  • Verze 1: Na stisknutí tlačítka na listu “Start” vloží nový prázdný list a vrátí se zpět na list “Start”
  • Verze 2: Vloží se 3 prázdné listy
  • Verze 3: Vloží se prázdné listy v počtu zadaném uživatelem do vyskakovacího okna
  • Verze 4: Do každého vloženého listu se vloží standardní hlavička (viz makro Hlavicka výše)
  • Verze 5: Uživatel si může zvolit, jak se listy budou jmenovat, (např. při volbě “Jirka” se listy budou jmenovat “Jirka 1”, “Jirka 2”, “Jirka 3” atd)
  • Verze 6: Při žádosti o vytvoření více než 10 listů makro odmítne vytvoření s tím, že to je příliš mnoho a vyžádá nový počet listů
  • Verze 7: Při vytvoření více než 8 listů makro varuje, že může běžet příliš dlouho.

2 Objednávky

Vytvořte makro, které zpracuje data na listu objednávky v pracovním sešitě:

Každému zaměstnanci pošle dokument se sloupcovým grafem s jeho výsledky. Každý zaměstnanec má email jmeno@jiribenedikt.com