Nevím z jakých důvodů ale uloz.to to opět po chvíli smázne a když to zkusím nahrát znovu, tak to zakáže že prý nebezpečný obsah. No nic, mordovat se s tím dále nebudu.
Zde je makro pro vygenerování vzorce =STYLE(OR(A2=jméno1;A2=jméno2; atd.). Chce to mít jména ve sloupci A, prázdno ve sloupci B a tři obarvovaná jména v C2:C4. Pak si makro nakopíruje do B2 vzorec =STYLE a pomocí CtrlC/V ho vloží do zbytku sloupce B (rozsah sloupce nastavit v makru - nyní je tam B3:B1000). Nebarví tak přímo hodnoty v A, ale pomocný sloupec B.
Sub generujStyle 'vygeneruje funcki =STYLE(...) do jedné buňky a z té pak pomcí Ctrl+C/V nakopíruje do ostatních; pak smázne obsah kam kopíroval, takže ve sloupci zbydou jen barvy
dim oDoc as object, oList as object, oBunka as object, sAdresaPrvni$, i&, j&, s$, sStyl$, sSloupec$, iRadek&
dim oPodmFormat as object, oPodminky(3) as new com.sun.star.beans.PropertyValue, args(0) as new com.sun.star.beans.PropertyValue
oDoc=ThisComponent
oList=oDoc.Sheets(0)
sStyl="Označeno" 'buňkový styl který se nastaví buňkám splňujícím podmínku ve =STYLE(...)
oBunkyJmena=oList.getCellRangeByName("C2:C4") 'buňky se jmény které se dají do podmínky
sAdresaPrvni="A2" 'adresa první buňky která bude jako podmínka pro vzorec =STYLE()
sAdresaVyplnPrvni="B2" 'první buňka do které makro umístí vzorec =STYLE()
sAdresaVypln="B3:B1000" 'ostatní buňky kam se dá =STYLE(); z té první se udělá Ctrl+C, pak se označí tyto a tam se to vloží -> takto si to automaticky změní adresy ve vzorci (tedy A2 na A3, A4 atd.)
rem vytvoření řetězce podmínky
p=oBunkyJmena.getDataArray
s="=STYLE(IF(OR("
for i=lbound(p) to ubound(p)
s=s & sAdresaPrvni & "=""" & p(i)(0) & """"
if i<>ubound(p) then s=s & ";"
next i
s=s & ");""" & sStyl & """))" '=STYLE(IF(OR(A2="jana";A2="kamil";A2="lenka");"Dobré"))
rem vyplní vzorcem první buňku
oBunka=oList.getCellRangeByName(sAdresaVyplnPrvni)
oBunka.formula=s
rem označit první buňku a Ctrl+C
oDoc.currentController.select(oBunka)
uno("Copy", oDoc)
rem označit zbylé buňky a Ctrl+V
args(0).Name="ToPoint" : args(0).Value=sAdresaVypln
uno("GoToCell", oDoc, args)
uno("Paste", oDoc)
rem smazat obsah i vzorce buněk, styl s barvou zůstane
args(0).Name="ToPoint" : args(0).Value=sAdresaVypln
uno("GoToCell", oDoc, args)
uno("ClearContents", oDoc)
args(0).Name="ToPoint" : args(0).Value=sAdresaVyplnPrvni
uno("GoToCell", oDoc, args)
uno("ClearContents", oDoc)
End Sub
Sub uno(s$, oDoc as object, optional args()) 'provede uno příkaz
if isMissing(args) then args=array()
s=".uno:" & s 'jaký uno příkaz
createUnoService("com.sun.star.frame.DispatchHelper").executeDispatch(oDoc.CurrentController.Frame, s, "", 0, args) 'provést
End Sub
Nastavovat přímo podmíněné formátování se mi povedlo jen buňku po buňce a bylo to hrozně pomaalý, makro zde. Jména jsou jména opět v A2:Aněco a filtr je C2:C4. Omezeno na 500 řádků.
global gPrerusit as boolean, goDocController as object, goKeyHandler as object
rem !!! POZOR, HROZNĚ POMALÝ, tolerovatelná rychlost tak do tisíc řádků!!!
Sub PodmineneFormatovani 'nastaví do rozsahu ve sloupci A podmíněné formátování dle jmen ve sloupci B
gPrerusit=false 'pro stisknutí Esc při ukazateli průběhu ve statusbaru
dim oDoc as object, oList as object, oBunka as object, oBunkyJmena as object, p(), i&, j&, s$, sStyl$, sSloupec$, iRadek&, oDocController as object, oStatusbar as object, max&, iKrok&
dim oPodmFormat as object, oPodminky(3) as new com.sun.star.beans.PropertyValue
oDoc=ThisComponent
oList=oDoc.Sheets(0)
oBunkyJmena=oList.getCellRangeByName("C2:C4") 'buňky se jmény do podmínky
p=oBunkyJmena.getDataArray
oBunky=oList.getCellRangeByName("A2:A500") 'buňky kam dát podmíněný formát
sSloupec=oBunky.Columns.ElementNames(0)
sStyl="Označeno" 'styl jaký nastavit barveným buňkám
rem ukazatel průběhu
goDocController=oDoc.currentController
oStatusbar=goDocController.statusIndicator 'objekt statusbaru
max=oBunky.Rows.Count
oStatusbar.start("Stisk Esc = Přerušit",max) 'inicializace ukazatele, text a maximální hodnota
RegisterKeyHandler
for i=oBunky.RangeAddress.StartRow to oBunky.RangeAddress.EndRow
s="OR(" 'řetězec podmíněného formátu
for j=lbound(p) to ubound(p)
s=s & sSloupec & i+1 & "=""" & p(j)(0) & """"
if j<>ubound(p) then s=s & ";"
next j
s=s & ")" 'podmínka pro buňku A2 bude třeba: OR(A2="jana";A2="kamil";A2="lenka")
oBunka=oList.getCellByPosition(oBunky.RangeAddress.StartColumn, i)
oPodmFormat=oBunka.ConditionalFormat
oPodminky(0).Name="Operator"
oPodminky(0).Value=com.sun.star.sheet.ConditionOperator.FORMULA
oPodminky(1).Name="Formula1"
oPodminky(1).Value=s
oPodminky(2).Name="StyleName"
oPodminky(2).Value=sStyl
oPodminky(3).Name="SourcePosition"
oPodminky(3).Value=oBunka.CellAddress
oPodmFormat.clear() 'smáznout předchozí podmíněné formátování v buňce
oPodmFormat.addNew(oPodminky())
oBunka.ConditionalFormat=oPodmFormat 'nastavit nové podmíněné formátování
if iKrok=20 then
oStatusbar.setValue(i) 'změnit hodnotu ukazatele statusbaru
iKrok=0
end if
iKrok=iKrok+1
if gPrerusit=true then exit for 'testování stavu pro Přerušení
next i
UnregisterKeyHandler 'ukončit zachytávání kláves
oStatusbar.end 'konec ukazatele průběhu
oStatusbar.reset 'reset statusbaru
End Sub
Sub RegisterKeyHandler 'aktivovat dokumentu zachytávání kláves
goKeyHandler=createUnoListener("Klavesa_", "com.sun.star.awt.XKeyHandler")
goDocController.addKeyHandler(goKeyHandler)
End Sub
Sub UnregisterKeyHandler 'deaktivovat zachytávání kláves
if not IsNull(goDocController) AND NOT IsEmpty(goDocController) then
goDocController.removeKeyHandler(goKeyHandler)
end if
End Sub
Function Klavesa_keyPressed(optional oEvt) as boolean 'obsluha stisku klávesy
if oEvt.keychar=chr(27) then gPrerusit=true 'stisknut Esc
Klavesa_keyPressed=false
End Function
Function Klavesa_keyReleased(optional oEvt) 'obsluha uvolnění klávesy
Klavesa_keyReleased=false
End Function
Function Klavesa_disposing(optional oEvt)
End Function
Vkládám spíše již pro zajímavost když to není na celou tabulku ale jen sloupec
Editoval kamlan (8. 4. 2021 10:36:04)
