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

Zápatí