Příspěvky uživatele

Toto makro Vám doplní Vami požadované PF do každej bunky označenej oblasti.
Sub SipkyPF()
Dim Bunka As Range, Adr As String, Lst As String

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With

With Selection
.FormatConditions.Delete
Lst = "='" & .Parent.Name & "'!"

For Each Bunka In .Cells
Adr = Lst & Bunka.Offset(-1, 0).Address
With Bunka.FormatConditions.AddIconSetCondition
.IconSet = ActiveWorkbook.IconSets(xl3Arrows)

.IconCriteria(1).Icon = xlIconRedDownArrow
With .IconCriteria(2)
.Type = xlConditionValueFormula
.Value = Adr
.Operator = 7
.Icon = xlIconRedDownArrow
End With

With .IconCriteria(3)
.Type = xlConditionValueFormula
.Value = Adr
.Operator = 5
.Icon = xlIconGreenUpArrow
End With

End With
Next Bunka

End With

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub

Nechcem byť prostredníkom, lebo ten vždy dopadne zle, ale podľa popisu toto vyzerá skôr na nejaké to PowerQuerry, a na to je majster užívateľ Mepexg. Skúste ho osloviť cez Vzkaz

Já to asi chápem. Ide o to, že pri tomto druhu PF, nieje možné použiť relatívne adresovanie ("...zrušit ukotvení..."). Dokonca to nefachá ani ak sa použije Def.Name. Ak by to bola napevno daná oblasť, tak by tie PF išli asi jednorázovo vložiť do každej bunky makrom. Inak neviem, ale už min raz tu presne rovnaký problém bol.

OT: Ak na to existuje riešenie, tak by sa dalo asi použiť aj pri inom obdobnom obmedzení. Načítavanie obrázku, cez prepojenie, ktoré odkazuje na vzorec. Po pretiahnutí inam, vzorec vracia správne hodnoty, ale prepojenie na obrázok sa nemení.

No dobre, aby ste nepovedal, že máte málo matrošu na štúdium, tak aby som Vám ešte viacej zamotal hlavu, pridal som ďalšie inšpiračné možnosti:

Pokus1 - Pomocou metódy Evaluate získate v jednom kroku vyhodnotenie pre každý riadok, či sa má skryť, alebo nie. Potom ale musí znovu nastúpiť cyklus a tieto oblasti spojiť do jednej, ktorá sa skryje. Ten, kto bude ten vzorec ale upravovať, ten sa z toho radovať nebude :)

Pokus2 - Defakto jednoriadkový kód. To okolo je potrebné pre každú metódu, lebo odkryť ich najskôr musíte vždy, aby boli uvedené riadky do východzieho stavu, a Application.ScreenUpdating je len kvôli prebliknutiu. Inak je to docela brutálne jednoriadkové riešenie, pri ktorom sa budú mnohí za hlavu chytať. 1. problém, ak nastane, že nieje čo skryť, sa dá ľahko obísť pridaním On Error Resume Next. Ale 2. problém je, že výsledná dlhočizná adresa všetkých buniek na skrývanie nesmie prekročiť 255 znakov. Čo u Vás prekročí. Je to obmedzenie metódy Range. Takže toto je u Vás nepoužiteľné, uvádzam len ako pikošku :)

Pokus3 - Opäť jednoriadkové riešenie, ktoré ale spolieha na pomocný (kľudne skrytý) stĺpec. Teraz je to stĺpec AM, v ktorom sú vzorce, ktoré podľa podmienok vyvolajú chybu na riadku, ktorý treba skryť. SpecialCells potom tieto bunky dokáže naraz identifikovať. Problém môže nastať, vlastne iba vtedy, ak nebude nič na skrývanie. A preto je tam On Error. Táto možnosť je pre Vás asi najvhodnejšia pre implementáciu a pochopenie.

Super. A vyriešili sa aj problémy s tým skrývaním

Sub Skryť_riadky()
Dim Praca(), RNG As Range, i As Byte, y As Byte, Riadok As Long, Pocet As Byte

Application.ScreenUpdating = False
Odkryť_riadky 'Najskôr všetky zobraziť

With ThisWorkbook.ActiveSheet
ReDim Praca(1 To 124, 1 To 1)
Praca = .Cells(8, 4).Resize(124).Value 'Načítať hodnoty

For i = 0 To 30 'Opakuj pre 31 skupín
Pocet = 0

For y = 2 To 4 'Kontroluj v skupine bunky 2,3,4
Riadok = i * 4 + y 'Riadok medzi hodnotami
If IsEmpty(Praca(Riadok, 1)) Then 'Ak je prázdny
Pocet = Pocet + 1 'tak zvýč počítadlo Počet prázdnych
If RNG Is Nothing Then Set RNG = .Cells(Riadok + 7, 1) Else Set RNG = Union(RNG, .Cells(Riadok + 7, 1)) 'a pridaj do skrývanej oblasti
End If
Next y

If Pocet < 3 And IsEmpty(Praca(i * 4 + 1, 1)) Then 'Ak sú bunky 2,3,4 v skupine prázdne, tak sa 1. neskryje, no ak je z 2,3,4 prázdnych menej ako 3, tak sa kontroluje či 1. je prázdna
If RNG Is Nothing Then Set RNG = .Cells(i * 4 + 8, 1) Else Set RNG = Union(RNG, .Cells(i * 4 + 8, 1)) 'ak 1. bunka v skupine je prázdna, tak sa skryje
End If
Next i

If Not RNG Is Nothing Then RNG.EntireRow.Hidden = True 'Ak sú nejaké bunky na skrývanie, tak ich skry
End With
Application.ScreenUpdating = True
End Sub

Alebo skúste takúto prkotinku s makrom pomocou Application.OnKey. Urobil som to tak, aby sa to aktivovalo len pri A3:Axxx, aby sa to deaktivovalo pri presune na iné stĺpce, iný list, iný dokument, a pri zatrovení dokumentu. Funguje to na obidva Enter. No skúste :)

Modul:
Public bZapnute As Boolean, bBoloPredtymZapnute As Boolean

Sub OnEnterSub()
Application.EnableEvents = False
With ActiveCell
If IsEmpty(.Value) Then .Value = .Offset(-1, 0)
.Offset(1, 0).Select
End With
Application.EnableEvents = True
End Sub

Sub ZapnutOnEnter()
Application.OnKey "~", "OnEnterSub"
Application.OnKey "{ENTER}", "OnEnterSub"
End Sub

Sub VypnutOnEnter()
bZapnute = False
Application.OnKey "~"
Application.OnKey "{ENTER}"
End Sub

List:
Private Sub Worksheet_Activate()
bZapnute = bBoloPredtymZapnute
If bZapnute Then ZapnutOnEnter
End Sub

Private Sub Worksheet_Deactivate()
bBoloPredtymZapnute = bZapnute
VypnutOnEnter
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 1 And Target.Row > 2 Then
If Not bZapnute Then bZapnute = True: ZapnutOnEnter
Else
If bZapnute Then VypnutOnEnter
End If
End Sub

Zošit:
Private Sub Workbook_Activate()
bZapnute = bBoloPredtymZapnute
If bZapnute Then ZapnutOnEnter
End Sub

Private Sub Workbook_Deactivate()
bBoloPredtymZapnute = bZapnute
VypnutOnEnter
End Sub

Priložte sem ten doplnok alebo odkaz naň. Možno na to niekto pozrie. Zo ScreenShotov sa to nedá otestovať.

Zaregistrujte sa, aby ste mohol vkladať prílohu. Max veľkosť 256 kb. Ak je to súbor *.xlsm, treba to zabaliť do ZIP. Citlivé údaje tam nemusíte nechávať, len ich prepíšte somarinami. Ukážte teda presne, ako to vyzerá, a ako príklad niekde bokom ku každému riadku napíšte napr. "s", akože tento riadok by sa mal skryť. A spáchame to nejako. Nieje nad reálne vyzerajúcu prílohu s požadovaným výsledkom...

Opravte ten odkaz na GoogleDrive. Časť z neho chýba.

Áno, zabudol som na posun, doplnte si vyznačenú časť do daného riadku:
sOblast = sOblast & .Range(AdrP(i)).Offset(, -1).Resize(47, 9).Address & " "

No ja neviem, musíte tam mať určite tie zlúčené bunky? Ak nie, tak v pohode bez makra Rozšíreným filtrom v objekte Tabuľka - ukážka v Hárok1. V Hárok 2 je +- nejaký návrh na makro.

Excel Vám to moje predošlé makro nezobral asi len kvôli tomu, že pri kopírovaní z fóra vkladá medzery medzi riadky. A zložený príkaz nesmie mať v sebe prázdne riadky. Stačilo odstrániť medzery.

Každopádne, tu je ďalší návrh s malým rozdielom číslovania príloh, ale tentoraz som použil malý cyklus, ktorý bude možno pochopiteľnejší. Prílohy budú očíslované v zadanom poradí, len sa vytlačia v poradí, ako idú pod sebou. Ale čísla budú mať aké im určíte Vy.

Stále trváte na tom, že sú oblasti rovnaké ? Poriadne sa pozrite na "A191:I232" vs "A191:I234" pre rovnakú prílohu. Detto v poslednej prílohe.
Ďalej prvá príloha je o riadok vyššia, ale budiš, nevadí.

Nečítal som všetko, ani nepozeral pridané riešenia, tak snáď neduplikujem.

Ak to ani takto nevyhovuje, tak potom (možno to tu už je) tlačte po jednotlivých prílohách pomocou cyklu. Prvá tlač tie 2 hlavné strany, druhá samostatná tlač bude prvá zvolená príloha, tretia samostatná tlač bude druhá zvolená príloha, atď. Kliknete rovnako iba raz na tlačítko, akurát nebudete mať ten Preview. Aj to je možnosť.

Sub Tisk()
Dim sOblast As String, AdrP, i As Byte

With ThisWorkbook.ActiveSheet
AdrP = Split("B96,B144,B191,B238", ",")
sOblast = "$A$1:$I$95 "
For i = 0 To 3
If IsNumeric(.Range(AdrP(i)).Value) Then
sOblast = sOblast & .Range(AdrP(i)).Offset(, -1).Resize(47, 9).Address & " "
End If
Next i
sOblast = Replace(WorksheetFunction.Trim(sOblast), " ", ",")
.PageSetup.PrintArea = sOblast
.PrintOut Preview:=True
End With
End Sub

Ak to robia aj iné programy, natiahnite všetky aktualizácie Win a aktualizujte hlavne ovládač tlačiarne. Ak to robí iba Excel, aktualizujte Office a zároveň aj tlačiareň.

Iný PC či notebook na tú tlačiareň ste neskúšal ?

V Preferenciách tlačiarne (nie v nastavení tlače v Exceli, ale priamo ovládač tlačiarne) nieje možnosť nejako zamknúť otáčanie ?

Tak ma napadá ešte takéto nematicové riešenie, ktoré nemá problém s vynechaním detských porcií a ráta ich podľa požiadavky, rovnako ako to maticové riešenie.
=SUMPRODUCT(INT(--SUBSTITUTE(A2:A4;"/";",")))&"/"&IFERROR(--REPLACE(SUMPRODUCT(--SUBSTITUTE(A2:A4;"/";",")-INT(--SUBSTITUTE(A2:A4;"/";",")));1;2;"");0)
=SOUČIN.SKALÁRNÍ(CELÁ.ČÁST(--DOSADIT(A2:A4;"/";",")))&"/"&IFERROR(--NAHRADIT(SOUČIN.SKALÁRNÍ(--DOSADIT(A2:A4;"/";",")-CELÁ.ČÁST(--DOSADIT(A2:A4;"/";",")));1;2;"");0)
Mepexg, neviem ako to myslíte, ale nepočíta Vám to správne detské porcie. Pri 4/2, 1/2, 2/2 má dať 6 detských, ale Vám dá 2. No a ak detské raz vynecháme 4/2, 1, 2/2 tak má dať 4 detské, Vám dá chybu.

Napríklad takto. Maticový vzorec:
=SUM(IFERROR(LEFT(A2:A4;FIND("/";A2:A4)-1)*1;A2:A4*1))&"/"&SUM(IFERROR(MID(A2:A4;FIND("/";A2:A4)+1;LEN(A2:A4))*1;0))
=SUMA(IFERROR(ZLEVA(A2:A4;NAJÍT("/";A2:A4)-1)*1;A2:A4*1))&"/"&SUMA(IFERROR(ČÁST(A2:A4;NAJÍT("/";A2:A4)+1;DÉLKA(A2:A4))*1;0))

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje