10307_vzor_pokus.rar
Uzamčeno - nelze přidávat nové příspěvky.
No asi se ti podarilo vylit s vanickou i dite, nebot ten zminovany kod casovace v modulu chybi.
Pokud by sis chtel ten sesit zalohovat, tak dej do ThisWorkbook nasledovny kod. Ten pri otevirani sesitu vytvori jeho zalohu na libovolnem miste, pricem na tomto miste bude 5 zaloh, ktere se budou postupne prepisovat, pokud od posledni zalohy uplynula urcita doba (zde jeden den). Je to pro stary excel, takze pokud budes ve formatu .xlsm, budes muset ten kod lehce upravit. Tech zaloh muzes mit kolik chces, ale musis je poprve na zalohovacim fleku vytvorit rucne, teprve pak se zacnou dokolecka prepisovat.
Private Sub Workbook_Open()
Dim Jmeno As String, Jmeno1 As String, Cesta As String
Dim Datum1 As Date, Max_Datum As Date, Min_Datum As Date
Dim Nejstarsi As Integer, Nejmladsi As Integer
Dim Cas, i%, Rozdil As Double
'kdyby ho mìl už nìkdo otevøený
If ActiveWorkbook.ReadOnly = True Then
MsgBox "Pozor, nìkdo už má tento soubor otevøený"
Exit Sub
End If
'když se to otevírá na PC doma, a se nic nedìje
If Application.UserName = "MD_doma" Then Exit Sub
'kdybychom otevírali záložný soubor, a se nic nedìje
If Left(Jmeno1, 4) = "Zal_" Then Exit Sub
Jmeno1 = ThisWorkbook.Name
Max_Datum = 100000
Min_Datum = 0
'musíme ze jména odstranit ".xls"
i = Len(Jmeno1)
Jmeno = Left(Jmeno1, i - 4)
'pøed to vložíme "Zal_" jako záloha
Jmeno = "Zal_" & Jmeno
'zadáme cestu, kam ukládáme zálohu
Cesta = "\\Server01\work_level\Zaloha\"
'tento cyklus projede všechny oèíslované záložné soubory a zjistí _
který je nejstarší a nejmladší
i = 1
Do
Jmeno1 = Cesta & Jmeno & i & ".xls"
'On Error Resume Next
If Dir(Jmeno1) = "" Then Exit Do
'On Error GoTo 0
Datum1 = FileDateTime(Jmeno1) * 1
If Datum1 < Max_Datum Then
If Datum1 > Min_Datum Then
Min_Datum = Datum1
Nejmladsi = i
End If
Max_Datum = Datum1
Nejstarsi = i
Else
If Min_Datum < Datum1 Then
Min_Datum = Datum1
Nejmladsi = i
End If
End If
i = i + 1
Loop
'kdyby nebyl nalezen žádný takový soubor, dej hlášku
If i = 1 Then
MsgBox "na místì " & Cesta & vbCr _
& " nebyly nalezeny záložné soubory" & vbCr & _
"Kontaktuj programátora"
Exit Sub
End If
'Nastavení minimálního intervalu zálohování 1 = 1 den
'porovnáme èas uložení nejmladšího a nynìjší èas
Cas = CDbl(FileDateTime(Cesta & Jmeno & Nejmladsi & ".xls"))
'zjisti rozdíl èasù
Rozdil = CDbl(Now) - Cas
'nápis ve stavovém øádku
Application.DisplayStatusBar = True
Application.StatusBar = "Poslední záloha byla uložena pøed " & Format(24 * Rozdil, "#0,0") & " hod"
If Rozdil > 1.5 Then
'pøepiš nejstarší zálohu
ActiveWorkbook.SaveCopyAs Cesta & Jmeno & Nejstarsi & ".xls"
End If
'vrátime excelu kontrolu nad stavovým rádkem
Application.StatusBar = False
Application.ScreenUpdating = True
End Subcitovat
Pokud by sis chtel ten sesit zalohovat, tak dej do ThisWorkbook nasledovny kod. Ten pri otevirani sesitu vytvori jeho zalohu na libovolnem miste, pricem na tomto miste bude 5 zaloh, ktere se budou postupne prepisovat, pokud od posledni zalohy uplynula urcita doba (zde jeden den). Je to pro stary excel, takze pokud budes ve formatu .xlsm, budes muset ten kod lehce upravit. Tech zaloh muzes mit kolik chces, ale musis je poprve na zalohovacim fleku vytvorit rucne, teprve pak se zacnou dokolecka prepisovat.
Private Sub Workbook_Open()
Dim Jmeno As String, Jmeno1 As String, Cesta As String
Dim Datum1 As Date, Max_Datum As Date, Min_Datum As Date
Dim Nejstarsi As Integer, Nejmladsi As Integer
Dim Cas, i%, Rozdil As Double
'kdyby ho mìl už nìkdo otevøený
If ActiveWorkbook.ReadOnly = True Then
MsgBox "Pozor, nìkdo už má tento soubor otevøený"
Exit Sub
End If
'když se to otevírá na PC doma, a se nic nedìje
If Application.UserName = "MD_doma" Then Exit Sub
'kdybychom otevírali záložný soubor, a se nic nedìje
If Left(Jmeno1, 4) = "Zal_" Then Exit Sub
Jmeno1 = ThisWorkbook.Name
Max_Datum = 100000
Min_Datum = 0
'musíme ze jména odstranit ".xls"
i = Len(Jmeno1)
Jmeno = Left(Jmeno1, i - 4)
'pøed to vložíme "Zal_" jako záloha
Jmeno = "Zal_" & Jmeno
'zadáme cestu, kam ukládáme zálohu
Cesta = "\\Server01\work_level\Zaloha\"
'tento cyklus projede všechny oèíslované záložné soubory a zjistí _
který je nejstarší a nejmladší
i = 1
Do
Jmeno1 = Cesta & Jmeno & i & ".xls"
'On Error Resume Next
If Dir(Jmeno1) = "" Then Exit Do
'On Error GoTo 0
Datum1 = FileDateTime(Jmeno1) * 1
If Datum1 < Max_Datum Then
If Datum1 > Min_Datum Then
Min_Datum = Datum1
Nejmladsi = i
End If
Max_Datum = Datum1
Nejstarsi = i
Else
If Min_Datum < Datum1 Then
Min_Datum = Datum1
Nejmladsi = i
End If
End If
i = i + 1
Loop
'kdyby nebyl nalezen žádný takový soubor, dej hlášku
If i = 1 Then
MsgBox "na místì " & Cesta & vbCr _
& " nebyly nalezeny záložné soubory" & vbCr & _
"Kontaktuj programátora"
Exit Sub
End If
'Nastavení minimálního intervalu zálohování 1 = 1 den
'porovnáme èas uložení nejmladšího a nynìjší èas
Cas = CDbl(FileDateTime(Cesta & Jmeno & Nejmladsi & ".xls"))
'zjisti rozdíl èasù
Rozdil = CDbl(Now) - Cas
'nápis ve stavovém øádku
Application.DisplayStatusBar = True
Application.StatusBar = "Poslední záloha byla uložena pøed " & Format(24 * Rozdil, "#0,0") & " hod"
If Rozdil > 1.5 Then
'pøepiš nejstarší zálohu
ActiveWorkbook.SaveCopyAs Cesta & Jmeno & Nejstarsi & ".xls"
End If
'vrátime excelu kontrolu nad stavovým rádkem
Application.StatusBar = False
Application.ScreenUpdating = True
End Subcitovat
přikládám správný file :) kde je i zbytek.
no ještě si s tím pohraju 
časem se do toho snad dostanu 
RSS nejnovější články