Příspěvky uživatele
< návrat zpět
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í
No nevím, jestli je šťastné řešení to, co vidím na listě 2021. Tomu se říká Google tabulka? Tedy dost nevhodně navrženo.
Ze zkušenosti bych šel do jiné struktury a to tak, že datumy by byly chronologicky pod sebou (třeba ve sloupci "A") a jednotlivá jména by byla ve čtvrtém řádku (ať to umožní do prvních řádků vložit souhrnné vzorce pro jednotlivé osoby)
A samotné hodnoty (nějaké zkratky pro přítomnost, dovolenku, SV...) by se nacházely v průsečníku daného dne a daného jména.
Předem si dovolím upozornit na chybějící rozměr jak tohoto, tak i "Google" řešení a tím jsou hodiny. Čili jak zaznamenat přesčas nebo 2 hodiny lékař a půl dne dovolené a podobné příklady ze života. V tomto je dobré mít jasno už na začátku.
Běžně používám kód na práci se skrytým listem, čili kopírování, filtrování a podobně. Ty zmiňované chyby mají nějaký kód či popis, třeba že ten skrytý list je ještě zamčený...
Uživatelské menu
\nMenu
On-line nástroje
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
RSS nejnovější články