Fórum pro uživatele kancelářského balíku OpenOffice | LibreOffice
 

#26 27. 8. 2021 17:20:15

kamlan
Člen
Registrace: 15. 9. 2016
Příspěvků: 368

Re: Tipy na zrychlení makro výpočtů

Aby třídění bylo co nejrychlejší tak - nemýlím-li se - je nejlepší mít v něm co nejméně druhů čísel. Takže následující makro nejprve vezme data z mazacího sloupce a zkopíruje je do nového dočasného listu a vše co není nula nahradí za -1 (dalo by se to udělat i pomocí uno příkazu uno:ExecuteSearch v daném listu jako při Ctrl+H se zašktrlým Pouze v současném výběru). Tudíž dostanu sloupec s hodnotami -1 a 0 a případně prázdnými buňkami (pokud v mazacím sloupci nic nebylo zadáno). Ten se zkopíruje do původního listu jako pomocný sloupec a podle toho se setřídí list. Což znamená, že pořadí řádků se nijak nezmění, akorát ty co měly nulu (či byly prázdné) se přesunou do jednoho bloku (dvou bloků) na konec. Pak se spočte kolik je těch nulových&prázdných a celý ten blok nulových/prázdných se smaže.
Na 100tis. řádcích mi to udělalo asi za 3 vteřiny. Kosmeticky by šlo asi urychlit zjišťování kolik je těch nulových/prázdných aniž by se to muselo procházet prvek po prvku v getDataArray (zjistit jaký znak je v polovině nějakého rozsahu a pak zase v polovině poloviny atd. až by se tím "půlením" došlo k poloze třeba prvního nulového znaku), ale počítám že by to mohlo mít snad smysl při milionech (či spíše miliardách) řádků, neb i po jednom je to záležitost ani ne vteřiny.

Sub mazani3
	'vezme data z "mazacího sloupce" a zkopíruje je do nového dočasného listu, tam jiné hodnoty než nulu nahradít za -1 a tato data zkopíruje zpět do pomocného sloupce v původním listě
	'dle pomocného sloupce setřídí list, takže napřed budou všechny řádky s hodnotami -1 v původním pořadí a na konci blok s nulami (případně za ním ještě blok s prázdnými buňkami), který se smaže a smaže se i pomocný sloupec
	'z listu tak budou odstraněny řádky které měly v mazacím sloupci nulu nebo v něm neměly žádnou hodnotu!
	on local error goto chyba
	dim oDoc as object, oSheet as object, oRange as object, data(), iSLoupec&, i&, iPocet&, i1&, i2&, aSkryt as variant, sList$, oSheets as object, bAutomatic as boolean, iSheet%, iEndColumn&, oCur as object, oSheetTemp as object, oNahr as object, sTemp$, aRange as new com.sun.star.table.CellRangeAddress
	dim cas as date : cas=Now
	oDoc=ThisComponent
	bAutomatic=oDoc.isAutomaticCalculationEnabled 'jak je to aktuálně s automatickým přepočtem
	if bAutomatic then oDoc.enableAutomaticCalculation(false) 'kdyžtak deaktivovat automatický přepočet
	oDoc.lockControllers() 'zakáže aktualizaci obrazovky
	oDoc.addActionLock() 'zakáže přepočet

	rem test existence požadovaného listu
	sList="FAKTURA" 'jméno listu
	oSheets=oDoc.Sheets 'listy sešitu
	if oSheets.hasByName(sList) then 'sešit list obsahuje
		oSheet=oSheets.getByName(sList) 'požadovaný list
		oSheets.moveByName(sList, 0) 'přesune list na první pozici
		iSheet=oSheet.RangeAddress.Sheet 'číslo požadovaného listu
	else
		msgbox(sList, 48, "List neexistuje")
		exit sub
	end if
 
	iSloupec=3 'sloupec dle kterého budu mazat (A=0, B=1 atd.)
	i1=1 : i2=8000 'testované řádky (první řádek=0, druhý=1 atd.)
	aSkryt=0 'hodnota pro kterou skrývám řádek (v případě řetězců třeba "0")

	rem zjistit čísla posledního použitého řádku a sloupce v listu
	oCur=oSheet.createCursor
	oCur.goToEndOfUSedArea(false)
	iEndColumn=oCur.RangeAddress.EndColumn 'poslední použitý sloupec v listu	
	if oCur.RangeAddress.EndRow<i2 then i2=oCur.RangeAddress.EndRow 'je-li méně řádků než kolik jich testuji tak zmenšit i2
	if iEndColumn=oSheet.RangeAddress.EndColumn then 'v listu jsou obsazené všechny sloupce
		msgbox "nelze umístit dočasný sloupec do listu faktura, neboť ten má obsazené všechny sloupce"
		goto konec
	end if
	
	oRange=oSheet.getCellRangeByPosition(iSloupec, i1, iSloupec, i2) 'mazací sloupec
	data=oRange.getDataArray() 'data z mazacího sloupce

	rem vytvořit dočasný list
	sTemp="Temp" 'jméno dočasného listu	
	if oSheets.hasByName(sTemp) then oSheets.removeByName(sTemp) 'existuje-li dočasný list tak odstranit
	oSheets.insertNewByName(sTemp, oSheets.Count) 'vložit dočasný list
	oSheetTemp=oSheets.getByName(sTemp) 'dočasný list
	oRange=oSheetTemp.getCellRangeByPosition(0, 0, 0, i2-i1)
	oRange.setDataArray(data) 'vložit do dočasného listu hodnoty z mazacího sloupce
	rem znaky krom nuly nahradit za -1
	oNahr=oSheetTemp.createReplaceDescriptor
	with oNahr
		.SearchString="^(.{2,}|[^0])$"
		.ReplaceString=-1
		.SearchRegularExpression=true
	end with
	oSheetTemp.replaceAll(oNahr)
	oRange=oSheetTemp.getCellRangeByPosition(0, 0, 0, i2-i1)
	data=oRange.getDataArray()
	oSheets.removeByName(sTemp) 'smazat dočasný list
	
	rem vytvořit pomocný sloupec v listu; dát do něj sloupec z dočasného listu; setřídit dle pomocného sloupce
	iEndColumn=iEndColumn+1
	oRange=oSheet.getCellRangeByPosition(iEndColumn, i1, iEndColumn, i2)
	oRange.setDataArray(data)
	oRange=oSheet.getCellRangeByPosition(0, i1, iEndColumn, i2)
	rem setřídit obsah dle mazacího sloupce - dostanu tedy všechny řádky s nulou na začátek
	dim tridpodle(0) as new com.sun.star.util.SortField, serad(0) as new com.sun.star.beans.PropertyValue
	tridpodle(0).Field=iEndColumn
	tridpodle(0).SortAscending=true
	'tridpodle(0).FieldType = com.sun.star.util.SortFieldType.NUMERIC 'jde jen o čísla ve sloupci
	serad(0).Name="SortFields"
	serad(0).Value=tridpodle()
	oRange.sort(serad())	'setřídit řádky dle pomocného sloupce

	rem zjistit blok s nulami, ten je díky třídění hodnot -1/0 na konci
	oRange=oSheet.getCellRangeByPosition(iEndColumn, i1, iEndColumn, i2)
	data=oRange.getDataArray()
	iPocet=0
	for i=ubound(data) to lbound(data) step -1
		if (data(i)(0)=aSkryt) OR (data(i)(0)="") then 'počet nulových nebo prázdných řádků
			iPocet=iPocet+1
		else
			exit for
		end if
	next i

	rem smazat pomocný sloupec; smazat nulové i prázdné
	oRange=oSheet.Columns.getByIndex(iEndColumn)
	oRange.clearContents(1) 'smazat obsah ve sloupci (nebo použít mazání rozsahu jako dále)
	rem smazat nulové&prázdné
	with aRange
		.Sheet=iSheet
		.StartColumn=0
		.StartRow=i2-iPocet+1
		.EndColumn=iEndColumn-1
		.EndRow=i2
	end with
	oSheet.removeRange(aRange, com.sun.star.sheet.CellDeleteMode.NONE) 'smazat řádky
	
konec:
	oDoc.removeActionLock() 'povolí přepočet
	oDoc.unlockControllers() 'povolí aktualizaci zobrazení
	oDoc.enableAutomaticCalculation(bAutomatic) 'původní nastavení automatického přepočtu	
	cas=Now-cas
	msgbox(Minute(cas) & ":" & Second(cas), 0, "Čas")
	exit sub
chyba:
	msgbox("Řádek: " & Erl & chr(13) & "Chyba č. " & Err & chr(13) & Error, 16, "LP_mazani")	
End Sub

Offline

#27 24. 9. 2024 11:01:57

barevnej
Člen
Registrace: 6. 8. 2015
Příspěvků: 172

Re: Tipy na zrychlení makro výpočtů

kamlan napsal(a)

Je potřeba otestovat existenci listu FAKTURA, to je na začátku a také se tam hned provede přesunutí listu na první pozici.


Když se maže přes .uno:DeleteRows tak je to nejrychlejší, ale musí to být prováděno v aktivním listu. List se aktivuje jednoduše příkazem oDoc.CurrentController.ActiveSheet=oSheet.
Přes API Basicu lze mazat vždy jen jeden rozsah buněk v listu metodou oSheet.removeRange (alespoň co já vím), takže to by bylo pomalejší - byť pak by to bylo naprosto nezávislé na tom který list je zrovna aktivní. Ale za to snížení rychlosti by se to asi nevyplatilo.

Sub NOVE_mazani 'pomocí com.sun.star.Sheet.SheetCellRanges + UNO pro skrýt označené řádky
	on local error goto chyba
	dim oDoc as object, oSheet as object, oRange as object, oRanges as object, oRangeAddress as new com.sun.star.table.CellRangeAddress, oEnum as object, o as object, data(), i&, iSloupec&, i1&, i2&, iSheet%, aSkryt as variant, sList$, oSheets as object
	dim oDlg as object, oPrubeh as object, oButton as object, iPrubeh&, bCancel as boolean 'pro ukazatel průběhu
	const iStep=30 : iPrubeh=0 'pro ukazatel průběhu
	
	oDoc=ThisComponent

	rem test existence požadovaného listu
	sList="FAKTURA" 'jméno listu
	oSheets=oDoc.Sheets 'listy sešitu
	if oSheets.hasByName(sList) then 'sešit list obsahuje
		oSheet=oSheets.getByName(sList) 'požadovaný list
		oSheets.moveByName(sList, 0) 'přesune list na první pozici (tenhle řádek se klidně může dát až na konec, tedy za dispatcher.executeDispatch)
		iSheet=oSheet.RangeAddress.Sheet 'číslo požadovaného listu
	else
		msgbox(sList, 48, "List neexistuje")
		exit sub
	end if
	
	iSloupec=3 'sloupec dle kterého budu skrývat (A=0, B=1 atd.)
	i1=1 : i2=3100 'testované řádky (první řádek=0, druhý=1 atd.)
	aSkryt=0 'hodnota pro kterou skrývám řádek (v případě řetězců třeba "0")
	
	oRanges=oDoc.createInstance("com.sun.star.sheet.SheetCellRanges") 'rozsahy vybraných buněk
	with oRangeAddress 'sloupce přidávaného rozsahu
		.Sheet=iSheet
		.StartColumn=iSloupec
		.EndColumn=iSloupec
	end with
	
		rem ukazatel průběhu
		oDlg=progressBarInit(0, i2-i1, oDoc)
		oDlg.title="Mažu nulové :-)"
		oPrubeh=oDlg.getControl("Pprogress")
		oButton=oDlg.getControl("Pbutton")
	
	oRange=oSheet.getCellRangeByPosition(iSloupec, i1, iSloupec, i2) 'data ze sloupce dle kterého skrývám řádky
	data=oRange.getDataArray
	dim iZac&, iKon&, a as variant, b as boolean
	iZac=i1 : iKon=0 : b=false
	
	rem hlavní smyčka
	for i=lbound(data) to ubound(data)

			rem ukazatel průběhu
			iPrubeh=iPrubeh+1
			if iPrubeh=iStep then 'vykreslovat až po nějakém počtu kroků
				oPrubeh.value=i
				iPrubeh=0 'reset aktuálního počtu kroků
			end if
			if oButton.Model.state=1 then 'stisknuto Cancel v ukazateli průběhu
				bCancel=true
				exit for
			end if

		rem porovnávání hodnot a přidávání do oRanges
		a=data(i)(0) 'aktuální hodnota ze sloupce -- v ukázce jde o číslo; v případě řetězců třeba a=CStr(data(i)(0))
		if a=aSkryt then 'hodnota je skrývaná
			if iKon=0 then iZac=i+i1 'nemám žádný počet řádků tedy jde o první řádek rozsahu tak pamatuji číslo řádku
			iKon=iKon+1 'zvětšuji počet řádků které budu přidávat do rozsahu
			b=true 'až narazí na neskrývaný řádek tak přidá rozsah
		elseif b=true then 'řádek nemá hodnotu při které se skrývá
			with oRangeAddress 'řádky přidávaného rozsahu
				.StartRow=iZac
				.EndRow=iZac+iKon-1
			end with
			oRanges.AddRangeAddress(oRangeAddress,true) 'přidat rozsah
			iKon=0
			b=false
		else 'šlo o neskrývaný řádek takže začátek přidávaného rozsahu bude minimálně na dalším řádku
			iZac=iZac+1
		end if
	next i
	
		rem pro ukazatel průběhu
		if bCancel=true then 'stisknuto Cancel v ukazateli průběhu
			msgbox("Přerušeno")
			goto konec
		end if
	
	if iKon>0 then 'poslední řádky ještě mají být skryty
		with oRangeAddress 'řádky přidávaného rozsahu
			.StartRow=iZac
			.EndRow=iZac+iKon-1
		end with
		oRanges.AddRangeAddress(oRangeAddress,true) 'přidat rozsah		
	end if

	rem skrýt rozsahy přes UNO - rychlé - ale funguje jen v aktuálním listě
	dim document as object, dispatcher as object
	oDoc.CurrentController.ActiveSheet=oSheet 'požadovaný list jako aktivní aby v něm správně provedl uno příkaz
	oDoc.CurrentController.Select(oRanges) 'označit rozsahy
	document=oDoc.CurrentController.Frame
	dispatcher=createUnoService("com.sun.star.frame.DispatchHelper")
	dispatcher.executeDispatch(document, ".uno:DeleteRows", "", 0, array()) 'UNO pro smazání označených řádků
konec:
	oDlg.dispose() 'deaktivovat ukazatel průběhu
	exit sub
chyba:
	msgbox("Řádek: " & Erl & chr(13) & "Chyba č. " & Err & chr(13) & Error, 16, "NOVE_mazani")	
End Sub

Tak po dlouhé době přestalo toto makro fungovat v LO 4:24.8.1-0ubuntu0.22.04.1~lo1 a končí dvěma po sobě jdoucími hláškami.
2024-09-24_11-50.png
2024-09-24_11-50_1.png

Krom vývojové verze mám na Ubuntu i verzi SNAP 24.2.6.2 tam a vlastně i ve všech předchozích verzích 24.8. to funguje, nefunguje to jen v té úplně poslední verzi. Používám to denně asi 30x.

Si říkám je to jen chyba ve vývojové verzi nebo se něco zásadního změnilo na vždy?

Offline

Zápatí