podmíněný formát - další podmínky

[ShaREmAn]

Zdravím všechny,
potřeboval bych pomoci s nastavením dalších podmínek pro formát v excelu. Už jsem pro vybarvováním buněk využil všechny tři dostupné podmínky v podmíněném formátu, ale potřeboval bych ještě víc. Jedna z věcí je, že vedle tabulky, která se neustále rozrůstá a má do ní přístup více uživatelů bych v sloupci "S" potřeboval vytvořit u každého řádku buď tlačítko, nebo aby bylo rozpoznáno, že je tam nějaká hodnota a ta by značila, že je záznam v řádku zrušený a text v něm by se přeškrtl (nebo by středem vedla čára, nebo tak něco). Pro jeden řádek bych to asi zvládl (možná ), ale jak to udělat pro všechny řádky s tím, že budou další přibývat?
Díky moc za případnou pomoc

[navstevnik]

Pokud akceptujes reseni typu "tak nejak", pak (Excel 97-2003) vyber radek a dale Format>Bunky>vyber Pismo a zaskrtni Preskrtnute v poli Efekty>OK, pripadne muzes zmenit barvu pisma. V Excel 2007 nejak podobne v pasu karet.

[ShaREmAn]

Jasne. Takhle by to manualne slo delat, ale chtel bych prave, aby to delalo automaticky bud po zakliknuti nejakeho ovladaciho prvku u kazdeho radku nebo po vypleni/zapsani hodnoty u kazdeho radku.

[mmmartin]

A co udělat makro, které by se spouštělo někde umístěným tlačítkem nebo klávesovou zkratkou a které by v řádku na pozici kurzoru změnilo písmo z normálního na přeškrtnuté?

[navstevnik]

V editoru VBA (Alt+F11) vloz do standardniho modulu nasledujici proceduru (formalni radek tabulky: zadat skutecny rozsah sloupcu tabulky bez ohledu na skutecny prvni radek tabulky, zde napr. A1:E1):

Kód: Vybrat vše

Option Explicit

Sub FormatovatBunky()
  Dim Radek As Range, RdSel As Range
  ' formalni radek tabulky - v radku 1:1 pro sloupce tabulky
  Set Radek = ActiveSheet.Range("a1:e1")
  ' identifikace vybraneho radku
  Set RdSel = Application.Selection
  ' formatovani: efekt preskrtnuty, barva fontu cervena
  With Radek.Offset(RdSel.Row - 1, 0).Font
    .Strikethrough = True
    .ColorIndex = 3  'xlAutomatic
  End With
End Sub

Pouziti:
v pozadovanem radku vybrat libovolnou bunku(y) a zavolat proceduru.
Volat proceduru je mozno klavesovou zkratkou nebo vlozenym tlacitkem na listu.

[ShaREmAn]

Tohle by to řešilo částečně. Dalo by se to udělat nějak tak, aby když zapíšu do posledního sloupce vedle řádku, který chci aby byl přeškrtnutý, nějakou hodnotu, tak se to přeškrtlo a když jsi smažu tak zase normal? Tak mě napadá, že to tlačítko není asi ideální řešení, protože nevím, jak provázat tlačítko s řádkem při kopírování a nastavovat každý zvlášť se mi nece

[navstevnik]

Takze jinak:
V editoru VBA (Alt+F11) vlozit do modulu listu s tabulkou nasledujici procedury (v Sub Worksheet_Change identifikace sloupce: zadat sloupec, ve kterem budou vkladany znaky vyvolavajici formatovani, zde napr.: S:S, a identifikace formatovani: formatovat - "~" - tilda, obnovit format- "#" - krizek, v procedure lze zmenit; v Sub FormatovatBunky formalni radek tabulky: zadat skutecny rozsah sloupcu tabulky bez ohledu na skutecny prvni radek tabulky, zde napr. A1:E1):

Kód: Vybrat vše

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim RwsOfs As Long
  Const FormStr As String = "~"  ' tilda
  Const ObnFormStr As String = "#"  ' krizek
  ' identifikace sloupce
  If Intersect(Target, Range("s:s")) Is Nothing Then Exit Sub
  If Target.Rows.Count > 1 Then Exit Sub
  RwsOfs = Target.Row - 1
  Application.EnableEvents = False
  On Error GoTo Err1
  ' identifikacni znak formatovani radku tabulky - FormStr
  If Target.Value = FormStr Then FormatovatBunky RwsOfs, True, 3: Target.Value = vbNullString
  ' identifikacni znak obnovy formatovani radku tabulky - ObnFormStr
  If Target.Value = ObnFormStr Then FormatovatBunky RwsOfs, False, 0: Target.Value = vbNullString
  On Error GoTo 0
Err1:
  Application.EnableEvents = True
End Sub

Sub FormatovatBunky(RwsOfs As Long, Strikethr As Boolean, ClrInd As Byte)
  Dim Radek As Range, Blok As Range
  ' formalni radek tabulky - v radku 1:1 pro sloupce tabulky
  Set Radek = ActiveSheet.Range("a1:e1")
  ' formatovani: efekt preskrtnuty, barva fontu cervena
  With Radek.Offset(RwsOfs, 0).Font
    .Strikethrough = Strikethr
    .ColorIndex = ClrInd
  End With
End Sub

Pouziti:
v pozadovanem radku v definovanem sloupci vlozit do bunky pro zformatovani znak "~", pro obnovu znak "#", vlozeny znak je procedurou odstranen (z duvodu jednoznacnosti zadani).

[ShaREmAn]

No tak to už je téměř ono! Vůbec jsem teda nepředpokládal, že to bude nakonec až tak složité . Nicméně ještě jedna věc - trochu mi vadí, že po zapsání se znak "ztratí". Jde to i tak, aby po zapsání např. tildy řádek změnil formát, ale tilda zůstala vedle tabulky zapsaná a v případě, že ji potom smažu se formát zase obnovil na původní?

P.S.: jelikož mám trochu základy v programování, tak jsem doufal, že na tomhle pochopím jak to funguje a budu to případně schopný do budoucna vytvářet sám. Nebudu

[navstevnik]

Obnova formatovani smazanim znaku vede k nejednoznacnosti: bude-li v bunce znak pro formatovani ("~") nahrazen jinym, nedojde ke zmene, bude-li vsak tento jiny znak odstranen, bude obnoven format.
Nize je upravena verze. Navic lze vybranim vice bunek v urcenem sloupci a smazanim obsahu ("~") obnovit format v prislusnych radcich, pricemz plati vyse uvedene.

Kód: Vybrat vše

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim RwsOfs As Long, RwsCnt As Long
  Const FormStr As String = "~"  ' tilda
  Const ObnFormStr As String = vbNullString
  Const ClrInd As Byte = 3 ' cervena barva fontu formatovane bunky
  ' identifikace sloupce
  If Intersect(Target, Range("s:s")) Is Nothing Then Exit Sub
  RwsCnt = Target.Rows.Count
  RwsOfs = Target.Row - 1
  Application.EnableEvents = False
  On Error GoTo Err1
  ' identifikacni znak formatovani radku tabulky - FormStr
  If Target.Resize(1, 1).Value = FormStr Then FormatovatBunky RwsOfs, RwsCnt, True, ClrInd
  ' identifikacni znak obnovy formatovani radku tabulky - ObnFormStr
  If Target.Resize(1, 1).Value = ObnFormStr Then FormatovatBunky RwsOfs, RwsCnt, False, 0
  On Error GoTo 0
Err1:
  Application.EnableEvents = True
End Sub

Sub FormatovatBunky(RwsOfs As Long, RwsCnt As Long, Strikethr As Boolean, ClrInd As Byte)
  Dim Radek As Range, Blok As Range
  ' formalni radek tabulky - v radku 1:1 pro sloupce tabulky
  Set Radek = ActiveSheet.Range("a1:e1")
  ' formatovani: efekt preskrtnuty, barva fontu ClrInd
  With Radek.Resize(RwsCnt, Radek.Columns.Count).Offset(RwsOfs, 0).Font
    .Strikethrough = Strikethr
    .ColorIndex = ClrInd
  End With
End Sub

[ShaREmAn]

Tak to je přesně ono!
Díky moc za pomoc. Oceňuju, že si někdo najde čas a udělá něco pro druhýho i když by nemusel.
Problém vyřešen.