Excel Makra VBA Příklady

Toto je stránka s příklady 15 hotových užitečných maker. Je to určeno pro mírně pokročilé uživatele, kteří si umí zkopírovat kód makra do svého Excelu.

Pokud to ještě neumíte, můžete se to naučit na mém firemím školení MS Excel, v mém online kurzu pro jednotlivce nebo webináři pro jednotlivce.

⚠️ Upozornění: Makra jsou již dnes historická technologie. Napište mi a já vám poradím, jak přejít na modernější nástroje jako je PowerQuery, OfficeScript a PowerAutomate.

Pokud se chcete v Excelu zlepšovat zdarma, přihlašte se k mým týdenním Excel tipům do emailu

Ú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
  • …

Tahák na makra zdarma

Stáhněte si tahák na makra. Přijde vhod zejména mírně pokročilým uživatelům.

Excel-Tahak-Makra-JiriBenedikt.com_Stáhnout

Makra z Internetu – příklady

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

Toto je několik mých oblíbených maker, které jsem prověřil, že by měly fungovat v MS Office 365 české i anglické verzi:

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

Pozor, nefunguje u dokumentů uložených na Onedrive nebo Sharepointu!

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

7a Jednoduchá verze pro ty, co nemají Outlook:

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

7b Pokročilejší verze, co funguje jen s Outlookem

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

Za řádek s příjemcem můžete přidat také řádky pro kopii a skrytou kopii. Více mailů oddělujte středníkem:

.cc = "adam@jiribenedikt.com;bara@jiribenedikt.com"
.bcc = "cyril@jiribenedikt.com"

Pokud nahradíte 

.display

příkazem

.send

Email se rovnou odešle bez náhledu.

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

Pomocná makra pro programování

Často potřebujete v makru procházet jednotlivé položky řádek po řádku až k poslednímu popsanému řádku. Protože nevíte, kolik řádků je, je potřeba využít nějaký postup. Já to dělám takto jako v makru níže. Pomocí tohoto makra můžete projít všechny hodnoty v daném sloupci a pro každou něco udělat – např. vložit list, který se jmenuje podle hodnoty dané buňky a podobně. Také můžete spočítat, kolik vlastně řádků v tabulce je:

Smyčka do posledního popsaného řádku

Pokud chcete jen vědět, jaký je poslední popsaný řádek v daném listu, můžete si jeho číslo takto uložit do proměnné:

lastrow = ActiveSheet.UsedRange.Rows.Count

Pokud chcete řádky upravovat po jednom od shora až po poslední řádek před prvním prázdným řádkem (nemusí to nutně být ten poslední, v případě, že jsou jen vynechané řádky).

Sub cyklus()

'kde začít
sloupec = 3
radek = 1

Do Until IsEmpty(Cells(radek, sloupec))

'sem přijde, co se dá opakovat pro každou buňku, jak jimi budeme postupně projíždět

    'například zde to přečte obsah řádku a vyskočí jako vyskakovací okno
    MsgBox (Cells(radek, sloupec))

'posunout se na další řádek
radek = radek + 1

'(pokud se chcete posouvat po sloupcích, jednoduše místo přičtení řádku o jedna přičtěte sloupec o 1)

Loop

'nyní je v proměnné řádek uložen první prázdný řádek. Pokud potřebujete vědět poslední popsaný řádek, tak to spočítáte takto

posledniradek = radek - 1
End Sub

Získejte přístup k dalším materiálům

Přihlašte se a získáte další Excel příklady, tajné tipy, triky a materiály. Každý týden obdržíte jednu novou věc zdarma: