Příspěvky uživatele

Pokud byste potřebovala ještě něco doladit, nebo čímkoliv pomoct, klidně napište na "sz" můžu Vám poslat číslo na WhatsApp. tam to bude vše rychlejší, než zde, sem chodím sporadicky.

Dobrý den,

do sešitu jsem vložil nový modul. Makro se nyní spouští automaticky po otevření souboru a po potvrzení načtení dat nabídne možnost vytvořit tiskový list a zobrazit náhled tisku.

Nebyl jsem si jistý, kam přesně jste chtěla modul umístit, ale předpokládám, že to už si případně doladíte. Stejně tak jsem neměl úplně jasno, zda si přejete tiskový list uchovávat i po použití. V aktuální verzi se po tisku – nebo po zavření náhledu – celý list automaticky smaže.

Dobrý den,

nejsem si úplně jistý, zda jsem správně pochopil celé zadání, ale připravil jsem jednoduché makro podle původního popisu. Do výstupu jsem zahrnul i všechny ostatní sloupce, které byly v samotném sešitě, i když je tady ve vlákně uvedeny nemáte.

Nejsem si ale jistý, zda požadujete i barevný tisk – aktuálně makro tiskne jen černobíle (případně to není problém upravit).

Pokud preferujete řešení přes UserForm s více možnostmi nastavení, rád to doplním, jen bych potřeboval podrobněji rozepsat, jaké varianty byste tam chtěla mít.

Stačí přidat řádek
.Range("A3:T" & posledni).Sort Key1:=.Range("T3"), Order1:=xlAscending, Header:=xlYes viz obrázek(ukazka.jpg)kam

Přikládám soubor, ve kterém jsem upravil a zjednodušil původní makro.
K tomu jsem přidal ještě dvě nová makra, která řeší import dat efektivněji:

1. Zkrácená a optimalizovaná verze původního makra – stejná funkce, ale výrazně jednodušší a rychlejší kód.

2. Makro s klasickým načtením (Workbooks.Open) – vezme ze zdrojového souboru pouze požadované sloupce, vloží je do listu Data, odstraní nepotřebné řádky a uloží výsledek jako .xlsx.

3. Makro s ADO (bez otevírání souboru) – ještě rychlejší varianta, která načítá data přímo z disku bez otevření Excelu; opět bere jen potřebné sloupce, uloží do listu Data, smaže nepotřebné řádky a vytvoří finální .xlsx.

Vše je nastaveno tak, aby se po zpracování mezidata z listu Data automaticky vyčistila. Ale jelikož nevím na kterém listu má být datum, (B1) tak jsem to přidal na list "makro" Samozřejmě je vše potřeba ověřit.

Nebo takhle,
s menším probliknutím obrazovky, jinak logika stejná jak u "Začátečníka"

Ahoj,
do původního kódu (nahoře) jsem přidal cestu, kterou jsi napsal

ahoj,
zkus tohle vložit do "ThisWorkbook", ale nezapomeň si upravit cestu ke složce (priečinku)
A hlavně dej vědět, jestli je to ono, minule jsi vůbec nereagoval. Slovíčko "Děkuji" vždy potěší

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim SlozkaMegaCloud As String
Dim nazevSouboru As String
Dim cestasNovymNazvem As String
Dim i As Integer
Dim soubor As String
Dim cisloPosledniZalohy As Integer

' Nastavení cesty k záložnímu adresáři na MEGA cloudu
SlozkaMegaCloud = CreateObject("WScript.Shell").SpecialFolders("mydocuments") & "\MEGA\Vyučtovanie\"

' Původní název souboru bez přípony
nazevSouboru = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - Len(".xlsm"))

' Inicializace maximálního indexu
cisloPosledniZalohy = 0

' Procházení všech souborů v záložní složce
soubor = Dir(SlozkaMegaCloud & "*.xlsm")
Do While soubor <> ""
' Kontrola, zda název souboru odpovídá formátu "Záloha X - NázevSouboru.xlsm"
If InStr(soubor, "Záloha ") > 0 And InStr(soubor, " - " & nazevSouboru & ".xlsm") > 0 Then
' Získání čísla zálohy z názvu souboru
i = Mid(soubor, 8, InStr(soubor, " - " & nazevSouboru & ".xlsm") - 8)
If IsNumeric(i) Then
' Aktualizace maximálního indexu
If CInt(i) > cisloPosledniZalohy Then cisloPosledniZalohy = CInt(i)
End If
End If
soubor = Dir
Loop

' Nastavení nového indexu pro záložní soubor
i = cisloPosledniZalohy + 1

' Vytvoření názvu pro záložní soubor
cestasNovymNazvem = SlozkaMegaCloud & "Záloha " & i & " - " & nazevSouboru & ".xlsm"

' Uložení záložního souboru
ThisWorkbook.SaveCopyAs cestasNovymNazvem
End Sub

ahoj,
já na to použil makro

zde jsou věci které jsem přidal:
1. Při kliknutí na buňku v rozsahu "A9:A39" se zobrazí rozevírací seznam s volbami: "x", "d", "n", "s".

2. Kliknutím na buňku "A1" se automaticky vyplní docházka pro celý měsíc: "x" pro pracovní dny, "s" pro svátky (kromě víkendů) a prázdné buňky pro víkendy.

3. Kliknutím na buňku "A2" se smažou všechny zadané hodnoty v rozsahu "A9:A39", což usnadňuje rychlé vymazání docházky.

4. Při zadání "d" (dovolená) nebo "n" (nemoc) se zobrazí InputBox, kde zadáte počet dnů pro zvolený stav.

5.Pokud zadáte příliš vysoký počet dnů (např. více dnů dovolené, než zbývá do konce měsíce), makro vás upozorní a automaticky omezí rozsah na maximální možný počet dnů.

6. dovolil jsem si výběr měsíců upravit, v buňce H3 je rozevírací seznam s měsíci , při změně vyčistí docházku, přepíše datumy a upraví řádky (schová řádky, dle počtu dnů v měsíci)

Ahoj,
tato jsi to myslel? viz příloha

ahoj,
nechápu moc zadání, bylo by lepši víc rozepsat

ahoj,

viz příloha

opravené makro,
samozřejmě pokud by těch souborů bylo víc, chtělo by ten kód přepsat (zjednodušit)
Sub AktualizaceDat()

Dim Cesta As String
Dim Soubor1 As String, Soubor2 As String, Soubor3 As String
Dim ChybejiciSoubory As String
Dim I As Integer

Cesta = ThisWorkbook.Path & "\"
Soubor1 = "01.xlsx"
Soubor2 = "02.xlsx"
Soubor3 = "03.xlsx"

' Inicializace prázdného řetězce pro chybějící soubory
ChybejiciSoubory = ""

' Kontrola existence souborů a přidání chybějících do seznamu
If Len(Dir(Cesta & Soubor1, vbNormal)) = 0 Then ChybejiciSoubory = ChybejiciSoubory & vbCrLf & Soubor1
If Len(Dir(Cesta & Soubor2, vbNormal)) = 0 Then ChybejiciSoubory = ChybejiciSoubory & vbCrLf & Soubor2
If Len(Dir(Cesta & Soubor3, vbNormal)) = 0 Then ChybejiciSoubory = ChybejiciSoubory & vbCrLf & Soubor3

' Pokud nějaký soubor chybí, zobrazíme pouze ty chybějící
If ChybejiciSoubory <> "" Then
MsgBox "Následující soubory neexistují:" & vbCrLf & ChybejiciSoubory, vbCritical, "Kontrola souborů"
Exit Sub
End If

' Pokud všechny soubory existují, zobrazíme datum poslední aktualizace a dotaz na aktualizaci
I = MsgBox(Soubor1 & " - " & FileDateTime(Cesta & Soubor1) & vbCrLf & _
Soubor2 & " - " & FileDateTime(Cesta & Soubor2) & vbCrLf & _
Soubor3 & " - " & FileDateTime(Cesta & Soubor3) & vbCrLf & vbCrLf & _
"Zahájit aktualizaci?", vbYesNo, "Vygenerováno.")

Select Case I
Case vbNo
Exit Sub
Case vbYes
MsgBox "Call Aktualizace"
'Call Aktualizace
End Select
End Sub

Já to včera zkoušel přes registr,
ale změna se stejně projevila až po nahlédnutí do "Nastavení centra zabezpečení".
Nepomohlo ani restart Excelu a ani PC, alespoň ne na Office 365.
WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Excel\Security\AccessVBOM", 1, "REG_DWORD"

Stačí přinutit uživatele aby si povolil objektové moduly už při prvním použití sešitu. Třeba zamknutím celého sešitu, nebo schovaní listů atd...

Příspěvky uživatele

Uživatelské menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje