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
