Pro informace o výuce Excelu klikněte zde

Pokud pracujete se sešitem Excelu, je dobré často soubor ukládat. Má to ale jeden háček, po uložení nelze použit příkazy Zpět a Znova (Platilo do verze 2003). To znamená, vyvarovat se uložení sešitu po provedení chybného příkazu. Taky můžete chtít ukládat různé verze sešitu, pro případné vrácení stavu k určitému datu, nebo můžete omylem zvolit Uložit místo Uložit jako a přepsat jsi tak původní soubor.

Následující makro vytvoří kopii aktivního souboru a uloží ji to složky Zaloha.

Sub ZalohaSouboru()
'--------------------------------------------------
'Vytvoření kopie aktivního souboru do složky Zaloha
'Složka Zaloha se vytvoří ve složce aktivního souboru
'Autor Radek Jureček
'---------------------------------------------------
Dim intWinCnt As Integer
Dim Win As Window
Dim strNovyNazev As String
Dim strCesta As String
Dim Fso As Object

'Kontrola, zda je aktivní nějaký sešit
'Platí pro umístění v doplňku
intWinCnt = 0
For Each Win In Application.Windows
   If Win.Visible Then intWinCnt = intWinCnt + 1
Next
If intWinCnt = 0 Then
   MsgBox "Není aktivní žádný sešit!", vbCritical
   Exit Sub
End If

'Kontrola, zda se aktivní sešit již uložen
If ActiveWorkbook.Path = vbNullString Then
   MsgBox "Sešit ještě nebyl uložen!", vbCritical
   Exit Sub
End If

'Vytvoří nový název ve tvaru: 'rok.měsíc.den-hodina.minuta' + '_' + 'Zaloha' + '_' + 'Jméno aktivního souboru'
strNovyNazev = Format(Now, "yyyy.mm.dd-hh.mm") & "_Zaloha_" & ActiveWorkbook.Name
'Uložení ve složce aktivního souboru
strCesta = ActiveWorkbook.Path & "\Zalohy"
'Případně nastavit cestu natvrdo např.: strCesta = "C:\Zalohy
'Nebo ve složce doplňku strCesta = ThisWorkbook.Path & "\Zalohy"

If MsgBox("Chcete vytvořit kopii souboru " & ActiveWorkbook.Name & vbCrLf & _
"do složky " & strCesta, vbInformation + vbYesNo) = vbNo Then Exit Sub

Set Fso = CreateObject("Scripting.FileSystemObject")
'Pokud složka Zalohy neexistuje, tak ji vytvoříme
If Fso.FolderExists(strCesta) = False Then Fso.CreateFolder (strCesta)

'Kontrola, zda již ve složce není soubor stejného názvu
If Fso.FileExists(strCesta & "\" & strNovyNazev) Then
   If MsgBox("Záloha s názvem " & strNovyNazev & " již existuje!!!" & vbCrLf & _
      "Chcete ji smazat a nahradit novou zálohou?", vbInformation + vbYesNo) = vbYes Then
      Kill strCesta & "\" & strNovyNazev
   Else
      Set Fso = Nothing
      Exit Sub
   End If
End If

'Uložení kopie souboru
ActiveWorkbook.SaveCopyAs Filename:=strCesta & "\" & strNovyNazev

Set Fso = Nothing
MsgBox "Byla vytvořena záloha souboru " & ActiveWorkbook.Name & vbCrLf & _
"do složky " & strCesta & vbCrLf & _
"s názvem " & strNovyNazev, vbInformation

End Sub