VBA – Užitečná makra 1.část

vba Před šesti lety jsem začal pracovat v kanceláři, kde se z devadesáti procent provádí rutinní práce v Excelu. Jelikož jsem typ člověka, který se všemožně snaží si ulehčit práci, začal jsem studovat Visual Basic, abych si mohl vytvořit makra, která některé procesy udělají samy, čímž usnadním práci sobě i svým kolegům. Po vytvoření desítek maker jsem zjistil, že některé úkony, jako například formátování, kopírování, mazání nepotřebných dat atp. se provádí ve více dokumentech, a tak abych nepsal stejnou proceduru několikrát, vytvořil jsem si šablony, které pouze upravuji dle potřeby.

Rozhodl jsem se některá nejpoužívanější makra vystavit na tomto serveru a věřím, že spoustu lidem usnadní práci. Z důvodu velkého počtu maker jsem článek rozdělil na několik částí. Další díl bude vystaven za několik dní.

Úplným začátečníkům nejdříve napíšu návod, jak vložit makro do VBA.

Vložení subrutiny do modulu:

Klávesová zkratka Alt+F11 --> v menu VBA: Insert --> Module --> do prázdného okna vpravo kopírujte subrutinu.
Podrobný postup vložení makra do modulu naleznete zde: http://www.bastleni.eu/vba/71-vlozit-makro

Vložení událostní procedury do ThisWorkBooku:

V Excelu: klávesová zkratka Alt+F11 --> v seznamu projektů vlevo dvakrát klikněte na položku ThisWorkBook --> do prázdného okna vpravo kopírujte proceduru.

Vložení událostní procedury do záložky:

V Excelu: Klikněte na název záložky a z kontextového menu vyberte možnost „Zobrazit Kód“
Do prázdného okna vpravo kopírujte proceduru.

A nyní už jen seznam těch nejpoužívanějších maker.

Automatické ukládání dokumentu

Excelový dokument se po určitém čase sám uloží.

ThisWorkbook:

Private Sub Workbook_Open()
Call cas
End Sub
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call ukladani
End Sub

Modul:

 

Public vartimer As Variant
Const TimeOut = 5 'zde si nastavte po kolika minutách se má dokument uložit
 
Sub ulozime()

ActiveWorkbook.Save
Call cas
End Sub
 
Sub cas()
vartimer = Format(Now + TimeSerial(0, TimeOut, 0), "hh:mm:ss")
If vartimer = "" Then Exit Sub
Application.OnTime TimeValue(vartimer), "ulozime"
End Sub
 
Sub ukladani()
On Error Resume Next
Application.OnTime earliesttime:=vartimer, _
procedure:="ulozime", schedule:=False
On Error GoTo 0
End Sub

Nyní stačí spustit makro "cas" a dokument se začne po vámi nastaveném čase automaticky ukládat. Po otevření dokumentu se makro spouští automaticky.

Časová platnost dokumentu

Hodí se například u ceníků a různých seznamů. V makru nastavíte kdy má být dokument neplatný. Po tomto datu se uživateli zobrazí informace, že seznam je zastaralý a dokument se zavře. Hlášku a datum si samozřejmě upravte podle sebe.

ThisWorkBook:

  

Private Sub Workbook_Open()
'nahrat do ThisWorkBook    
platnost = DateValue("29.3.2008") 'platnost dokumentu do
dnes = Date
If platnost < dnes Then
MsgBox "Dokument je již neplatný. Stáhněte si aktualní seznam na našich stránkách", vbCritical + vbOKOnly, "Dokument je zastaralý!!"
End If
ActiveWorkbook.Close False
End Sub

Pokud buňka splňuje podmínku, smaže se celý řádek

Záložka:

   

Private Sub Worksheet_Change(ByVal Target As Range)
If Selection.Count = 1 Then
With Target
If .Column = 1 Then
If .Value = "OK" Then .EntireRow.Delete 'pokud uživatel v prvním sloupečku vyplní slovo „OK“, řádek se smaže.
End If
End With
End If
End Sub

Vymaže všechny obrázky v dokumentu

Modul:

   
Sub smazat_obrazky()
ActiveSheet.Pictures.Delete
End Sub

Text napsaný malými písmeny se přepíše na velká

Hodí se zejména v dokumentech, kde si nepřejete, aby uživatelé psali malým písmem. Pokud tedy uživatel něco napíše malým písmem, obsah buňky bude automaticky upraven. V subrutině je nastavena oblast A1:A10. Tu si nezapomeňte nastavit podle sebe.

Záložka:

    

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Application.Intersect(Target, Range("A1:A10")) Is Nothing Then
Target(1).Value = UCase(Target(1).Value)
End If
Application.EnableEvents = True
End Sub

Smaže všechny záložky, kromě jedné

Máte-li v dokumentu spoustu záložek, které už nepotřebujete, smažte se naráz tímto makrem.

Modul:

     

Sub smazat_zalozky()
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In Worksheets
' záložku List1 nesmaže
If ws.Name <> "List1" Then ws.Delete
Next
Application.DisplayAlerts = True
End Sub

Vložení nových řádků

S tímto makrem velmi rychle vložíte tolik nových řádků, kolik jen budete chtít.

Modul:

      

Sub vlozit_radky()
Dim Rng
Rng = InputBox("Zadej počet řádků")
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(Rng - 1, 0)).Select
Selection.EntireRow.Insert
End Sub

Zkopíruje obsah buňky do komentáře

Potřebujete-li obsah buňky vložit do komentáře a nudí vás kopírování, označte buňku či buňky kde je to potřeba a spusťte níže uvedenou subrutinu.

Modul:

 

Sub VlozTextDoKomentare()
Dim cell As Range
On Error Resume Next
Selection.ClearComments
On Error GoTo 0
For Each cell In Intersect(Selection, ActiveSheet.UsedRange)
If cell.Formula <> "" Then
cell.AddComment
cell.Comment.Visible = False
On Error Resume Next
cell.Comment.Text Text:=cell.FormulaLocal
On Error GoTo 0
End If
Next cell
End Sub

Vytvoří klikatelný seznam všech listů v dokumentu

V aktivním listu, ve sloupečku A se vytvoří klikatelný seznam všech listů v dokumentu. Seznam je užitečný především v dokumentech, které obsahují mnoho listů.

Modul:

  

Sub seznam_listu()
Dim ceLL As Range
Columns(1).Insert
For i = 1 To Sheets.Count
Cells(i, 1) = Sheets(i).Name
Next i
For Each ceLL In Range("A1", Range("A1").End(xlDown))
ceLL.Hyperlinks.Add anchor:=ceLL, Address:="", _
SubAddress:="'" & ceLL.Value & "'" & "!a1", ScreenTip:="Kliknutím se přesuneš do tohoto listu", TextToDisplay:=ceLL.Value
Next
End Sub

Hromadné vytvoření záložek s názvy ze sloupce

Velmi užitečné makro v případě že potřebujete vytvořit například 100 záložek. Ušetří to spoustu času!
Do prvního sloupečku vepište názvy záložek a spusťte makro.

Modul:

   

Sub vytvorit_listy()
Dim rozsah As Range, bunka As Range
Dim sesit As Worksheet
Dim start As Worksheet
Dim text As String
Set start = ActiveSheet
start.AutoFilterMode = False
' *** sloupeček s názvy pro listy ***
Set rozsah = Range("A1", Range("A65536").End(xlUp))
Application.DisplayAlerts = False
'*** přidáme si pomocný list ***
Worksheets.Add().Name = "xxx-xxx"
' *** filtrujeme data ***
With Worksheets("xxx-xxx")
rozsah.AdvancedFilter xlFilterCopy, , _
Worksheets("xxx-xxx").Range("A1"), True
Set rozsah = .Range("A1", .Range("A65536").End(xlUp))
End With
On Error Resume Next
With start
For Each bunka In rozsah
text = bunka
.Range("A1").AutoFilter 1, text
Worksheets(text).Delete
'*** a vyrábíme nové listy ... ***
Worksheets.Add().Name = text
.UsedRange.Copy Destination:=ActiveSheet.Range("A1")
ActiveSheet.Cells.Columns.AutoFit
Next bunka
End With
With start
.AutoFilterMode = False
.Activate
End With
'*** smažeme pomocný list ***
Worksheets("xxx-xxx").Delete
On Error GoTo 0
Application.DisplayAlerts = True
End Sub

Záloha dokumentu

Po spuštění níže uvedené subrutiny se vytvoří záloha dokumentu. Nezapomeňte si v subrutině upravit cestu do adresáře kam se má záloha uložit.

Modul:

   
Sub ulozit()
Cil = "c:\Záloha" 'adresář pro uložení zálohy
On Error Resume Next
MkDir Cil
ActiveWorkbook.SaveCopyAs Filename:=Cil & _
"\" & "Záloha_" & (Format(Now, "d.m.yyyy")) & ".xls"
ActiveWorkbook.Save
MsgBox "Soubor byl úspěšně uložen", vbInformation, "Uloženo"
End Sub

Další užitečná makra naleznete v příštím článku. Pokud máte nějaké dotazy, tak neváhejte a pište do komentářů nebo diskuzního fóra.

Autor: Michael Ruprecht (mike007)

Komentářů (0)

Pouze registrovaní uživatelé mohou přidat komentář!