Příspěvky uživatele

OK, no to bude na dýl.
Jestli rozumím správně vyjádření "ako si uložím do Hárok2 data ešte pred prepísaním ?", tak chceš po vyplnění formuláře uložit data do tabulky. Ale jistotu nemám, mate mně tam to "ešte pred prepísaním".
Slušný form má umožńovat načtení zaznamu z listu do formu, listování jednotlivými záznamy, editaci existujících záznamů a uložení nového. S čím chceš začít?

Posílám v příloze. Zamykání si uprav, s průřezem nejde pracovat při zamčeném listě, tak jsem zamykací ceremonie deaktivoval
V kódu pro list 5, na kterém se ten průřez (angl. Slice) nachází je událostní procedura Worksheet_PivotTableUpdate, která pak volá rutinu VytvorSoubor, které předává název, jaký má vytvořit.
Zbytek si musíš dotvořit dle svých představ, které jsou popsány jenom mlhavě

To je jaksi divně popsáno. Ten lichý/sudý týden určuješ vzorcem v podmíněném formátování anebo podle barev (jak píšeš)? Pokud jsi si na prvním listě poradil s určováním sudého / lichého týdne, tak stejně to můžeš udělat i na těch dalších. Anebo jinak: co ti brání použít nějakou další buňku, která ponese informaci sudý/lichý a podle ní pak nastavíš podmíněné formátování na všech listech?

Šlo by to řešit mnoha způsoby. Kdysi jsem potřeboval vytvořit nový sešit z vyfiltrovaných hodnot. Pokud tam filtr není, tak to vytvoří sešit ze všech hodnot. Ve smyčce se tam upravují i šířky sloupců podle originálu. Zkoušel jsem to a funguje to, případně se to dá volně upravit. Zde je kód:
Sub Kopie_listu_filtr()
'z aktivního listu vytvoří nový sešit s pouze přefiltrovanými řádky

Dim jMxCol As Integer
Dim iMxRow As Long, i As Long, iHlp As Long
Dim sgHlp As Single
Dim wbNew As Workbook
Dim ws As Worksheet, wb As Workbook
Dim strFiltAdr As String, strFormat As String
Dim FiltHelp As Boolean
Dim rgAdresa As String

Set wb = ActiveWorkbook
Set ws = ActiveSheet
rgAdresa = ActiveCell.Address

Application.ScreenUpdating = False

'poslední řádek na aktivním listě
'vyzkoušej prvních 10 sloupců
For i = 1 To 10
iHlp = Cells(65000, i).End(xlUp).Row
If iHlp > iMxRow Then iMxRow = iHlp
Next i

'poslední sloupec na aktivním listě
'vyzkoušej prvních 20 řádků
For i = 1 To 20
iHlp = Cells(i, 250).End(xlToLeft).Column
If iHlp > jMxCol Then jMxCol = iHlp
Next i

''pokud není nasazený Filtr, zeptej se jak dál
' If Not w1.FilterMode Then
' If vbNo = MsgBox("Není zadáno žádné filtrování. Budu tedy kopírovat všech " & iMxRow & " řádků " & vbCr & vbCr & _
' "Mám v akci pokračovat?", vbYesNo) Then Exit Sub
' End If

'zjisti rozměry filtru (pro pozdější nasazení stejného filtru do nového souboru)
If ws.AutoFilterMode Then
strFiltAdr = ws.AutoFilter.Range.Address
iHlp = ws.AutoFilter.Range.Columns.Count
FiltHelp = True
End If

'vytvoř nový soubor
Workbooks.Add
Set wbNew = ActiveWorkbook

'kopíruj řádky
wb.Activate
Rows("1:" & iMxRow).Select
Selection.Copy

'vlož kopírované řádky
wbNew.Activate
Selection.PasteSpecial Paste:=xlFormats
' Selection.PasteSpecial Paste:=xlFormulas
Selection.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False

'překopíruj šířku sloupců a formát
For i = 1 To jMxCol
wb.Activate
sgHlp = Columns(i).ColumnWidth
' strFormat = Cells(7, i).NumberFormat

wbNew.Activate
Columns(i).ColumnWidth = sgHlp
' If strFormat <> "@" Then Columns(i).NumberFormat = strFormat
Next i

'pokud tam byl filtr, tak nakopíruj i filtr
If FiltHelp Then
Range(strFiltAdr).Select
Selection.AutoFilter
End If

'zkopíruj nastavení lupy
wb.Activate
sgHlp = ActiveWindow.Zoom
wbNew.Activate
ActiveWindow.Zoom = sgHlp

Application.ScreenUpdating = True

Range(rgAdresa).Select

End Sub

Jak již pravil Komenský, je potřeba postupovat od jednoduššího k složitějšímu. Čili to jednodušší jsem poskytl, je to komentované a věřím, že přehledné.
Tak se do toho ponoř. Kód se krokuje klávesou F8, aktuální hodnoty proměnných se ukazují když na ně najedeš myší.

Pokud některé části kódu nerozumíš, vysvětlím.
Je mnohem lepší si svůj kód umět udržovat a modifikovat sám, než pak při každé změně okolností somrovat hotové řešení. Stejné neomaleně mi to bylo kdysi naznačeno, tak jsem se to raději naučil...

Třeba takhle:
Public Sub EXPORT_Harku_do_textu()

Application.EnableEvents = False
' tento zapis zaisti to, ze bude znemoznene volanie procedur spustenych na zaklade udalosti. Na konci kodu je nutne udalosti znovu 'zapnut'

Dim cesta As String
Dim nove_meno As String
Dim cele_meno As String
Dim zdroj As String

Dim i As Long, iMxRow As Long

iMxRow = Range("E65000").End(xlUp).Row
If iMxRow > 4 Then
For i = 4 To iMxRow
Cells(i, "E") = CStr(Cells(i, "E").Text)
Next i
End If

zdroj = ActiveWorkbook.Name ' nastavenie mena zdroju - meno povodneho zositu
cesta = ActiveWorkbook.Path ' nastavenie cesty pre ulozenie dat - tam kde bol povodny zosit otvoreny
Application.DisplayAlerts = False

ActiveSheet.Copy ' skopiruje cely aktivny harok do noveho zositu
ActiveSheet.Cells.UnMerge ' zrusi zlucenie buniek
Workbooks(zdroj).ActiveSheet.Cells.Copy ' skopiruje povodny harok
ActiveSheet.Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' iba hodnoty skopiruje do noveho harku (aby nekopirovalo pripadne vzorce vsetko potrebujem mat v texte)
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Cells.NumberFormat = "@" ' nastavi format celeho noveho harku do textu, pretoze cely harok musi byt vo formate textu
ActiveSheet.Columns("H").NumberFormat = "0000 000 000"

nove_meno = "Zosit " ' predpis noveho mena
Dim filename As Variant ' nastavenie cesty pre ulozenie
filename = Application.GetSaveAsFilename(nove_meno, "Excel (*.xlsx),*.*,Excel 98-03 (*.xls),*.*,", 1, "Uložiť ako") ' zobrazi sa okno 'ukladania'
If filename = False Then Exit Sub
cele_meno = filename
ActiveWorkbook.SaveAs (cele_meno) ' ulozenie zositu do standartnej cesty ukladania

ActiveSheet.Cells(1, 1).Select ' odklikni oznacenie celeho harku
Application.DisplayAlerts = True
Application.CutCopyMode = False
Application.EnableEvents = True ' volanie procedur spustenych na zaklade udalosti 'zapnut'
End Sub

Za splnění podmínky definované v předchozím postu posílám řešení. Je tam jedno tlačítko a email se vygeneruje podle údajů v řádku kde stojí kurzor.
Tlačítko je na listě 02BBB. Do dalších ho stačí jednoduše zkopírovat

Pozn: v původní příloze jsem měl chybku, opraveno

Ta struktura listu osoby je divná.
To by nešlo udělat jako rozumnou tabulku? Kde ve sloupci A by bylo to číslo, ve druhém jméno a ve třetím buď celá e-mailová adresa anebo alespoň jméno bez diakritiky, tak jak to figuruje v adrese.
Pak by to bylo docela snadné

V principu je to tak.
Důležité je dodržet zásadu, že oblast převodové tabulky musí být ve vzorci SVYHLEDAT zadána tak, aby vyhledávací sloupec byl prvním sloupcem nalevo

funkce svyhledat (vlookup). Ta předpokládá, že máš někde převodovou tabulku
Honza;51;10
František;52;8:45
atd.
Mrkni do nápovědy na příklady

Ve svém kódu řeším něco podobného, čili ukládám list jako samostatný soubor. Zde je část, která vymaže všechny Shapes (což jsou třeba tlačítka, obrázky atd,) kromě některých. Rozlišuje se to podle typu Shape.Type

'velikost loga a textboxu se rozhodila, tak ji nastavíme znovu
For i = ActiveSheet.Shapes.Count To 1 Step -1
With ActiveSheet.Shapes(i)
If .Type = 13 Then 'type 13 je logo
.LockAspectRatio = msoFalse
.Height = 20
.Width = 184
ElseIf .Type = 17 Then 'type 17 je textbox
.LockAspectRatio = msoFalse
.Height = 22
.Width = 145
Else 'jinak smazat
.Delete
End If
End With
Next i

Posílám kus kódu, kde vkládám obrázek (shPodpis As Shape) do buňky (rBunka as Range), a to tak, aby obrázek nepřesahoval velikost buňky ani do výšky ani do šířky:
Zamknutí poměru výška/šířka mám úmyslně zakomentované, ale fungovalo to

Set shPodpis = Worksheets("podpisy").Shapes(strJmeno)
Set rBunka = Worksheets("KryciList").Range("E10")

With shPodpis
.Name = strNazev
' .ShapeRange.LockAspectRatio = msoTrue 'uzamknout poměr šířky a výšky
.Top = rBunka.Top + 2
.Width = rBunka.Width - 2 'roztáhni podpis na šířku buňky
If .Height > rBunka.Height Then
.Height = rBunka.Height - 2 'pokud je vyšší než buňka, tak ten podpis zmenši
Else
.Top = rBunka.Top + (rBunka.Height - .Height) / 2
End If
.Left = rBunka.Left + (rBunka.Width - .Width) / 2 'vycentruj to v buňce vodorovně
End With

No tak konečně známe pravý účel makra, který byl na počátku jen mlhavě naznačený.
Tomu by pak odpovídalo i řešení.

No nic ...

Zde inspirace jak to dělat "košér". Snad si to upravíš dle sebe:
Dim strA As String, strB As String
Dim i As Integer, iMax As Integer
Dim ws As Worksheet

ThisWorkbook.Activate
Set ws = Worksheets("List1")

'poslední řádek:
iMax = Application.Max(ws.Range("A65000").End(xlUp).Row, ws.Range("B65000").End(xlUp).Row, ws.Range("C65000").End(xlUp).Row)

'vyskládej text za směnu A
strA = "Směna A:" & vbCrLf
For i = 1 To iMax Step 3
strA = strA & vbTab & ws.Cells(i, "A") & vbTab & ws.Cells(i, "D") & vbCrLf
Next i

'vyskládej text za směnu B
strB = "Směna B:" & vbCrLf
For i = 2 To iMax Step 3
strB = strB & vbTab & ws.Cells(i - 1, "A") & vbTab & ws.Cells(i, "D") & vbCrLf
Next i
MsgBox Prompt:=strA & vbCrLf & strB, Buttons:=vbOK, Title:="Přehled plných směn"

přidal jsem do tvého původního souboru jeden list.
Buď můžeš scrolovat, abys viděl příslušné období, anebo si příslušný měsíc či měsíce zafiltrovat.
A pokud bys to chtěl ještě vidět v nějaké sumární tabulce, to už nebude tak složité.
Plus se to dá dotunit vychytávkami, jak to má lugr. Šlo mi jen o to, že proč se přizpůsobovat nevhodné formě, někde ztažené z Googlu, která byla navržena zřejmě pro jiný případ. I verze co měsíc to nový list jsem historicky opustil už před lety, preferuji data na jednom místě a přizpůsobit jenom způsob jejich zobrazení

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje