Příspěvky uživatele

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...

Ahoj, tady makro viz níže, které maže komplet všechny makra co je v sešite.
Vložit do Thisworkbook

Private Sub Workbook_Open()
Dim VBProj As Object
Dim VBComp As Object
Dim Modul As Object
Dim DatumSmazani As Date

' Nastav požadované datum smazání
DatumSmazani = DateValue("2025-02-13") ' Změň na požadované datum

' Pokud je dnešní datum vyšší nebo rovno zadanému datu, smaže kód
If Date >= DatumSmazani Then
' Povolit přístup k VBA projektu
Set VBProj = Thisworkbook.VBProject

' Projít všechny moduly a smazat je
For Each VBComp In VBProj.VBComponents
Select Case VBComp.Type
Case 1, 2, 3 ' Standardní moduly, třídy a uživatelské formuláře
VBProj.VBComponents.Remove VBComp
Case 100 ' Modul sešitových událostí (např. ThisWorkbook, List1,...)
Set Modul = VBComp.CodeModule
Modul.DeleteLines 1, Modul.CountOfLines
End Select
Next VBComp
MsgBox "Uplinula doba trial verze, všekeré makra byly odstraněny!"
End If
End Sub

A co ten datum?
Bude vázaný na buňku, fixně nastavený v makru, z userformu, nebo jakým způsobem se dopracuje k tomu datumu?

Písmo ve sloupcích "E:G" (jak píše elnino) byla bíla barva.
A já se divil proč mi vzorec nic nevrací

Koukám, že já zadaní špatně pochopil ohledně vzorců "F:G", elninoslov to má správně. Tak to prosím ignorujte.

A sloupec "E" se bude muset dořešit, jak píše kolega, pokud práce budou na etapy a bude mezera v pracovních dnech.

A omlouvám se, že do této konverzace skáču, už se dále nebudu vměšovat

Ahoj,
tak koukám, že mě elninoslov předběhl

, ale už to sem přidám když jsem se stím hrál

jj ta bílá barva mi taky zamotala hlavu

Ahoj,
provedl jsem úpravy, přidal jsem podmínku aby bral v potaz řádky jenom 2 až 150 zbytek přeskočí.
Taky jsem upravil duplicitu. není to zrovna elegantní řešení, ale snad funkční. Pokud by to někdo chtěl upravit nebudu se zlobit

ahoj,
tak snad jsem pochopil zadaní, původní makro jsem zakomentoval a dal tam svůj, plus jsem přidal seřazení dat pro ostatní listy. Dělá to jenom do řádku 150 jak bylo i v zadání.
Radši si to pořádně zkontroluj jestli to dělá co má, než použiješ naostro.

ahoj,
do určeného listu (List1) vlož:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(False, False) = "A3" Then Call tvojeMakro
End Sub
místo "tvojeMakro" vlož svoje makro

Dobrý den,
tady bych raději použil makro.
Option Explicit

Sub RozdelAdresy()
Dim ws As Worksheet
Dim posRdk As Long
Dim i As Long
Dim ulice As String
Dim popisne As String
Dim regEx As Object
Dim matches As Object

' Nastavení listu, kde jsou data
Set ws = ThisWorkbook.Sheets(1) ' Změň číslo listu, pokud je potřeba

With ws
' Najde poslední řádek ve sloupci D
posRdk = .Cells(.Rows.Count, "D").End(xlUp).Row

' Vytvoření RegEx objektu
Set regEx = CreateObject("VBScript.RegExp")
regEx.Global = True
regEx.Pattern = "^(.*?)(\d.*)$"

' Prochází všechny řádky ve sloupci D
For i = 2 To posRdk ' Předpokládáme, že hlavička je na řádku 1
If .Cells(i, "D").Value <> "" Then
' Zpracuje adresu pomocí RegEx
If regEx.Test(.Cells(i, "D").Value) Then
Set matches = regEx.Execute(.Cells(i, "D").Value)
ulice = Trim(matches(0).SubMatches(0))
popisne = Trim(matches(0).SubMatches(1))
Else
ulice = .Cells(i, "D").Value
popisne = ""
End If

' Zapíše rozdělené části do sloupců D a R
.Cells(i, "D").Value = ulice
.Cells(i, "R").Value = popisne
End If
Next i
End With

MsgBox "Rozdělení adres dokončeno!", vbInformation
End Sub

Dobrý den,

chvilku mi trvalo to rozchodit, nejsem moc zběhlý v xml.

Aspoň mi to v práci uteklo a můžu domů

Mám Office 365 a tam mi to funguje, tak snad nebude problém s jinou verzí excelu.

Kdyžtak se na to podívejte. (viz příloha)

V Office RibbonX Editoru jsem upravil .xml viz kód
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui" onLoad="Initialize">
<ribbon startFromScratch="false">
<tabs>
<tab id="TabFormular" label="Moje" keytip="f">
<group id="SkupinaNovyZaznam" label="nový záznam">
<button id="btnNovyZaznam" label="zadat nový" size="large" onAction="NovyZaznam_makro" imageMso="ReviewAcceptChangeMenu" />
<separator id="SeparatorNovyZaznam1" />
<button id="btnTisk" label="tisk" size="large" onAction="Tisk_makro" imageMso="FilePrint" />
</group>

<group id="SkupinaPocetStran" label="počet stran">
<toggleButton id="toggleNaJednuStranu" label="na 1 stranu" onAction="PocetStran1_makro" getPressed="GetPressedJednaStranu" />
<toggleButton id="toggleNaDveStrany" label="na 2 strany" onAction="PocetStran2_makro" getPressed="GetPressedDveStrany" />
</group>

<group id="SkupinaFormulare" label="tisk formuláře">
<checkBox id="chkPlech" label="PLECH" onAction="ChkPlech_makro" getPressed="GetPlechState" />
<checkBox id="chkTyc" label="TYČ" onAction="ChkTyc_makro" getPressed="GetTycState"/>
<checkBox id="chkTycObrna" label="TYČ obrana" onAction="ChkTycObrna_makro" getPressed="GetTycObrnaState" />
</group>
</tab>
</tabs>
</ribbon>
</customUI>

Ahoj,
tak trochu nechápu proč od řádku 5 až 12 nemá být žádný nalez, když taky obsahuje slovo "oprava"
Jinak zkus se na to podívat, co jsem poslal.

Ahoj,
viz "pravidla fóra"

3. Příloha - pro snazší zodpovězení dotazu je vždy užitečné připojit přílohu (nedoporučuje se vkládat odkazy na externí úložiště), která je názornější než tisíc slov ... Registrovaní uživatelé mohou vkládat přílohy:
- ve formátech: .gif .jpg .png .txt .zip .rar .tar .7z,
- s maximální velikostí 256 kB a
- názvy neobsahující diakritiku
- přílohu lze vložit i dodatečně v úpravě příspěvku

nebo v buňce A1 je název listu

=SVYHLEDAT(C3;NEPŘÍMÝ.ODKAZ("'"&A1&"'!B:F");5;0)
nebo
=VLOOKUP(C3;INDIRECT("'"&A1&"'!B:F");5;0)

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje