Hromadná změna datumu a času v buňkách je realizovatelná ručním přepisem, funkcemi DATUM a ČAS (ve VBA funkce DateSerial a TimeSerial), případně funkcí EDATE a poslepováním dalších funkcí. Připomínám, že pro aktuální datum slouží klávesová zkratka Ctrl + ; (středník), a pro čas Ctrl + Shift + : (dvojtečka). Na listu daný úkol zvládají i funkce DNES a NYNÍ (čas je rozdíl NYNÍ-DNES), ve VBA pak máme funkce Date a Now, resp. Time.

Ruční úpravy datumu a času ve více buňkách jsou asi nejotravnější možností. Na numerickém bloku klávesnice nemáme k dispozici ani tečku pro datum, ani dvojtečku pro čas (u ní navíc potřebujeme Shift). U datumu si můžeme pomoci tak, že kupříkladu vstup 9/1 do (předem naformátované) buňky Excel zamění za 9.1. aktuálního roku (9.1.2019). Pro čas se hodí přidat nahrazení dvou čárek za dvojtečku do Automatických oprav (viz Soubor / Možnosti / Kontrola pravopisu a mluvnice / tlačítko Možnosti automatických oprav). Zápis 9,,26 bude tedy nahrazen za 9:26.

Celé je to ale kostrbaté a pomalé. My se proto dnes naučíme, jak posouvat datum a čas oběma směry s využitím maker a vestavěné funkce DateAdd, jež nabízí ve svém prvním parametru řadu možností pro posun jak v kalendáři, tak v čase obecně. Lehce jsem se přitom inspiroval článkem Entering Times Into Cells.
V případě datumu nebudeme ošetřovat případ, kdy by překročilo hranici 1.1.1900, což je na listu nejzazší datum (zatímco ve VBA je jím 1.1.100). U času už si ovšem musíme pohlídat překlápění přes půlnoc. A problémů je u něj daleko více. Ve VBA existuje jen jeden datový typ společný datumu a času – Date. Při vracení hodnot typu Date zpět do listu můžeme narazit na problémy s formátem buňky. Proto je jistější vracet interní hodnotu – pro datum je jím velké celé číslo a pro čas desetinné číslo. Pro algoritmus se tedy hodí matematické a konverzní funkce. Musíme si přitom uvědomit rozdíly mezi funkcemi Int a CInt, a stejně tak přibrzdit při myšlence použít operátor Mod (který se chová jinak, než funkce MOD na listu).
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | Sub DatumPosun(Jednotka As String, Posun As Integer) Dim varPole() As Variant Dim varPolozka As Variant Dim lngHodnota As Long 'prvni parametr pro DateAdd 'yyyy ... Year 'q ... Quarter 'm ... Month 'y ... Day of year 'd ... Day 'w ... Weekday 'ww ... Week 'pokud neni vybrana oblast bunek... If TypeName(Selection) <> "Range" Then 'opusteni procedury Exit Sub End If 'vypnuti prepoctu listu Application.Calculation = xlCalculationManual 's vyberem... With Selection 'redimenzovani pole ReDim varPole(1 To .Rows.Count, 1 To .Columns.Count) 'pro kazdou bunku vyberu For i = 1 To UBound(varPole, 1) For j = 1 To UBound(varPole, 2) 'test na datum If IsDate(.Cells(i, j)) Then 'prepocet datumu lngHodnota = CLng(DateAdd(Jednotka, Posun, _ .Cells(i, j))) varPole(i, j) = lngHodnota 'pokud v bunce neni datum Else 'pouze prevzeti obsahu bunky varPole(i, j) = .Cells(i, j) End If Next j Next i End With 'preklopeni pole zpet do listu Selection = varPole 'zapnuti prepoctu listu Application.Calculation = xlCalculationAutomatic End Sub |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | Sub CasPosun(Jednotka As String, Posun As Integer) Dim varPole() As Variant Dim varPolozka As Variant Dim dblHodnota As Double 'prvni parametr pro DateAdd 'h ... Hour 'n ... Minute 's ... Second 'pokud neni vybrana oblast bunek... If TypeName(Selection) <> "Range" Then 'opusteni procedury Exit Sub End If 'vypnuti prepoctu listu Application.Calculation = xlCalculationManual 's vyberem... With Selection 'redimenzovani pole ReDim varPole(1 To .Rows.Count, 1 To .Columns.Count) 'pro kazdou bunku vyberu For i = 1 To UBound(varPole, 1) For j = 1 To UBound(varPole, 2) 'test na cas ... Dick Kusleika If IsDate(.Cells(i, j).Text) And Not IsDate(.Cells(i, _ j).Value) Then 'prepocet casu dblHodnota = Abs(CDbl(DateAdd(Jednotka, Posun, _ .Cells(i, j)))) varPole(i, j) = dblHodnota - Int(dblHodnota) Else 'pouze prevzeti obsahu bunky varPole(i, j) = .Cells(i, j) End If Next j Next i End With 'preklopeni pole zpet do listu Selection = varPole 'zapnuti prepoctu listu Application.Calculation = xlCalculationAutomatic End Sub |
Pozn. Jestliže na listu chybí ekvivalent VBA funkce DateAdd, pak list vrací úder v podobě funkce WORKDAY, která pro změnu nemá sestřičku pod VBA. Musíme si ji tedy buď doprogramovat, nebo si ji vypůjčit přes WorksheetFunction.WorkDay (což je lepší varianta, protože případné svátky je také výhodnější generovat na listu, v reálu řekněme plus minus jeden rok vůči aktuálnímu roku). Níže uvedený kód čerpá svátky z pojmenované oblasti buněk – definovaný název Svatky (list Výpis svátků z přílohy).
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | Sub PracovniDenPosun(Posun As Integer) Dim varPole() As Variant Dim varPolozka As Variant Dim lngHodnota As Long 'pokud neni vybrana oblast bunek... If TypeName(Selection) <> "Range" Then 'opusteni procedury Exit Sub End If 'vypnuti prepoctu listu Application.Calculation = xlCalculationManual 's vyberem... With Selection 'redimenzovani pole ReDim varPole(1 To .Rows.Count, 1 To .Columns.Count) 'pro kazdou bunku vyberu For i = 1 To UBound(varPole, 1) For j = 1 To UBound(varPole, 2) 'test na datum If IsDate(.Cells(i, j)) Then 'prepocet datumu lngHodnota = _ CLng(WorksheetFunction.WorkDay(.Cells(i, j), _ Posun, Range("Svatky"))) varPole(i, j) = lngHodnota 'pokud v bunce neni datum Else 'pouze prevzeti obsahu bunky varPole(i, j) = .Cells(i, j) End If Next j Next i End With 'preklopeni pole zpet do listu Selection = varPole 'zapnuti prepoctu listu Application.Calculation = xlCalculationAutomatic End Sub |
Nyní již vám nic nebrání zpracovat vlastní varianty procedur a řídit tak posuny pro datum a čas programově.
1 2 3 4 5 6 7 | Sub TestDatumCasPosun() Call DatumPosun("ww", 1) 'Call CasPosun("h", -1) 'Call PracovniDenPosun(-3) End Sub |
Ke stažení
datum_cas_posun.zip