Makro na funkci Seskupit... (F12)

[Petr123]

Našel by se, prosím, někdo, kdo by byl ochoten mi i za peníze vytvořit pro LibreOffice Calc makro (nebo nějak jinak), které by umělo na aktivním listu provést funkci Seskupit (F12) pro určité skupiny řádků?

Pokusím se popsat co potřebuji, ukázka tabulky v příloze, kde na části řádků je Seskupit provedeno, ale potřebuji to automatizovaně udělat všude.

Mám tabulku, kde jsou různě seskupení řádků, které mají ve sloupci (D) text “VV”. Tyto bloky řádků potřebuji na celém listu Seskupit. Tedy příklad tabulky:
řádek 9 = prázdný
řádek 10 = různě text a čísla různé sloupce (ve sloupci (D) je text, ale jiný jak na řádku 11)
řádek 11 = sloupec (D) text “VV”
řádek 12 = sloupec (D) text “VV”
řádek 13 = sloupec (D) text “VV”
řádek 14 = různě text a čísla různé sloupce
řádek 15 = různě text a čísla různé sloupce
řádek 16 = sloupec (D) text “VV”
řádek 17 = sloupec (D) text “VV”
řádek 18 = různě text a čísla různé sloupce
řádek 19 = sloupec (D) text “VV”
řádek 20 = různě text a čísla různé sloupce

Potřebuji makrem docílit, aby Seskupilo řádky 11-13 a 16-17 a 19.

Makra umím jen naprosté základy a toto je už nad moje síly.

Děkuji za pomoc, Petr

Tabulka Seskupit F12.ods (24.8 KB)

[KamilLanda]

Tak makro máte zde, otestujte:

Sub seskupit 'seskupí řádky dle hodnoty ve sloupci D
	const sRetezec="VV" 'řetězec podle kterého se má seskupovat
	const iSloupec=3 'číslo sloupce (A=0, B=1, C=2, D=3 ...)
	const sZpet="Seskupit makrem" 'hláška pro krok Zpět
	
	dim oDoc as object, oSheet as object, oColumn as object, oCur as object, i&, j&, oRanges as object, oRange as object, data(), b as boolean, o as object, oCells as object, _
		undoMgr as object, bSeskupeno as boolean
	oDoc=ThisComponent
	undoMgr=oDoc.undoManager 'manažer kroků Zpět
	oSheet=oDoc.CurrentController.ActiveSheet 'aktuální list
	oCur=oSheet.createCursor 'listový kurzor
	oCur.gotoStartOfUsedArea(false) 'kurzor na začátek použité oblasti listu
	i=oCur.RangeAddress.StartRow 'první použitý řáděk
	oCur.gotoEndOfUsedArea(false) 'kurzor na konec použité oblasti listu
	j=oCur.RangeAddress.EndRow 'poslední použtý řádek listu
	oColumn=oSheet.getCellRangeByPosition(iSloupec, i, iSloupec, j) 'použitý sloupec D
	oRanges=oColumn.CellFormatRanges 'rozsahy buněk s různým formátem ve sloupci D
	for each oRange in oRanges 'procházet jednotlivé rozsahy
		data=oRange.getDataArray() 'obsah buněk v rozsahu
		b=true
		for each o in data 'obsah bunky v rozsahu
			if o(0)<>sRetezec then 'v buňce není seskupovaný řetězec
				b=false
				exit for
			end if
		next
		if b then 'v rozsahu buněk jsou jen požadované řetězce
			if NOT bSeskupeno then 'ještě nebylonic seskupeno tak zapnout manažer Zpět
				undoMgr.enterUndoContext(sZpet) 'hláška pro Zpět
				bSeskupeno=true
			end if
			oSheet.ungroup(oRange.RangeAddress, 1) 'zrušit seskupení když tam je (aby nebylo podruhé)
			oSheet.group(oRange.RangeAddress, 1) '1 = seskupit řádky rozsahu
		end if
	next
	if bSeskupeno then undoMgr.leaveUndoContext 'bylo něco seskupeno tak ukončit manažer Zpět
End Sub

zdroj: How to group colums or rows in LibreOffice Calc using macro - #4 by JohnSUN

[Petr123]

Otestoval, funguje, děkuji moc!
Kam a kolik Kč pošlu?
Petr