Sub kopirujCenyDoSloupcu
const sList1="List1" 'zdrojový list
const sList2="sloupce" 'název cílového listu
const iParu=10 'počet párů Qty&Cena
const iZac=3 'index sloupce kde je první Qty (indexy jsou od nuly, A=0, D=3)
dim oDoc as object, oList1 as object, oRange1 as object, oList2 as object, sZahlavi$, iList2&, data as object, oRange2 as object, oCur1 as object, p1(), oRangeP as object, _
iRadkuP&, i&, j&, k&, oRangeP2 as object, oSloupec as object
oDoc=ThisComponent
oList1=oDoc.Sheets.getByName(sList1)
if oDoc.Sheets.hasByName(sList2) then 'když cílový list existuje
' if 6=msgbox(sList2 & chr(13) & "List již existuje, smazat?", 4) then 'dotaz zda-li smazat existující cílový list
oDoc.Sheets.removeByName(sList2) 'tak jej smazat
' else
' exit sub
' end if
end if
iList2=oList1.RangeAddress.Sheet+1 'index (pozice) cílového listu
oDoc.Sheets.insertNewByName(sList2, iList2) 'vložit cílový list za výchozí list
oList2=oDoc.Sheets(iList2)
sZahlavi="A1:E1" 'adresa záhlaví tabulky
oRange1=oList1.getCellRangeByName(sZahlavi) 'buňky záhlaví
oDoc.CurrentController.Select(oRange1)
data=oDoc.CurrentController.getTransferable 'kopírovat záhlaví
oRange2=oList2.getCellRangeByName(sZahlavi) 'buňky záhlaví v cílovém listu
oDoc.CurrentController.Select(oRange2)
oDoc.CurrentController.insertTransferable(data) 'vložit záhlaví
createUnoService("com.sun.star.frame.DispatchHelper").executeDispatch(oDoc.CurrentController.Frame, ".uno:Deselect", "", 0, array()) 'provést
oCur1=oList1.createCursor()
oCur1.goToEndOfUsedArea(false) 'v proměné je adresa posledního použitého řádku a sloupce
oRangeP=oList1.getCellRangeByPosition(oRange1.RangeAddress.StartColumn, oRange1.RangeAddress.StartRow+1, oCur1.RangeAddress.StartColumn, oCur1.RangeAddress.StartRow)
p1=oRangeP.getDataArray() 'data z výchozího listu
iRadkuP=CLng((oCur1.RangeAddress.EndColumn-oRange1.RangeAddress.EndColumn+2)/2) 'maximum řádků z jednoho sloupce
dim p2((ubound(p1)+1)*iRadkuP) 'pole pro setDataArray do cílového rozsahu
for i=lbound(p1) to ubound(p1) 'projíždět data z výchozího listu po řádku
if p1(i)(0)="" AND p1(i)(1)="" AND p1(i)(2)="" then
'sloupce Materiál, Jednotka, Rate jsou prázdné
else 'nějaké údaje o materiálu jsou tak zapsat
for k=iZac to iZac+iParu step 2 'další řádky dle toho jak jsou vyplněné dvojice Qty&Cena atd., projíždí všechny sloupce takže nějaké údaje mohou chybět (např. může chybět Qty5Cena5 ale je-li vyplněné Qty6Cena6 atd. tak už to zapíše)
if p1(i)(k)<>"" OR p1(i)(k+1)<>"" then 'alespoň 1 hodnota z Qty&Cena je, tak zapsat
p2(j)=array( p1(i)(0), p1(i)(1), p1(i)(2), p1(i)(k), p1(i)(k+1) )
j=j+1
end if
next k
end if
next i
redim preserve p2(j-1) 'cílové pole jen pro tolik řádků kolik bylo vytvořeno
oRangeP2=oList2.getCellRangeByPosition(oRange2.RangeAddress.StartColumn, oRange2.RangeAddress.StartRow+1, oRange2.RangeAddress.StartColumn+ubound(p2(0)), oRange2.RangeAddress.StartRow+j ) 'cílový rozsah
oRangeP2.setDataArray(p2) 'vložit data do cílového rozsahu
oSloupec=oList2.getCellRangeByPosition(oRange2.RangeAddress.EndColumn, oRange2.RangeAddress.StartRow+1, oRange2.RangeAddress.EndColumn, oRange2.RangeAddress.StartRow+j)
oSloupec.NumberFormat=102 '102=měna 1234,50 Kč; 2=číslo typu 1234,00
rem setřídit data
dim oDesc as object, aSortFields(1) as new com.sun.star.table.TableSortField
oDesc=oRangeP2.createSortDescriptor
oDesc(1).Value=false 'rozsah je bez hlavičky
aSortFields(0).Field=0 'sloupec A jako první vzor pro třídění
aSortFields(0).IsAscending=true
aSortFields(1).Field=3 'sloupec D jako druhý vzor pro třídění
aSortFields(1).IsAscending=true
oDesc(3).Value=aSortFields()
oRangeP2.sort(oDesc) 'setřídit
End Sub