Apache OpenOffice: forum della comunità

Codice: Seleziona tutto

Sub Main
Dim Sh As Object
Dim LastRow As Long

Doc = ThisComponent
Sh = Doc.Sheets.GetByName("Foglio1")
c = Sh.createCursor
c.gotoEndOfUsedArea(false) 
LastRow = c.RangeAddress.EndRow

Dim Dic As Object
Dim oSortFields(1) As New com.sun.star.util.SortField
Dim oSortDesc(0) As New com.sun.star.beans.PropertyValue

ColonnaOut = 8
For colonna = 0 To 6 Step 2
Set Dic = CreateObject("Scripting.Dictionary") 
   For i = 1 To LastRow 
       Numero = Sh.getCellByPosition(colonna, i).Value
       If Numero <> 0 Then
          If Dic.Exists(Numero) = False Then
             Dic.Add Key:= Numero , Item:= 1
          else
            valore = Dic.Item(Numero )
            Dic.Remove(Numero )
            Dic.Add Key:= Numero , Item:= valore + 1
          end if
      End if
   Next i

   colKey = ColonnaOut + colonna
   colItem = ColonnaOut + colonna + 1
   For i = 0 To Dic.Count()-1
     Sh.getCellByPosition(colKey, i+1).Value =  Dic.Keys()(i)
     Sh.getCellByPosition(colItem, i+1).Value =  Dic.Items()(i)
   Next i
  
  
  oCellRange = Sh.getCellRangeByPosition(colKey, 1, colItem, LastRow)
  oSortFields(0).Field = colItem    ' 4 colonna nel range, si parte da 0
  oSortFields(0).SortAscending = false
  oSortFields(1).Field = colKey     ' prima colonna nel range, si parte da 0
  oSortFields(1).SortAscending = true
  oSortDesc(0).Name = "SortFields"
  oSortDesc(0).Value = oSortFields()
  oCellRange.Sort(oSortDesc())
  
next colonna
   
end sub

Codice: Seleziona tutto

Sub Search_Number()
Dim mySearch As Object, myResult As Object, myElement As Object
Dim mySearch2 As Object, myResult2 As Object
Dim Valore As string
Dim i as Integer, k As integer
Dim oRange As Object
Dim collezione As New Collection

For i=0 To 12 Step 3
	thisComponent.sheets(0).Getcellrangebyposition(i,16,i+1,19).ClearContents(1)
	oRange= thisComponent.sheets(0).Getcellrangebyposition(i,9,i,12)
	mySearch = orange.createSearchDescriptor()
	mySearch.searchRegularExpression = True
	mySearch.searchString            = "[0-9]*"          
	myResult = oRange.findAll(mySearch)
	If myResult.hasElements Then
		myarray=myResult.getData()
		For k = 0 to Ubound(myarray)
			Valore=Str(myarray(k)(0))
			On Error Resume next
				collezione.Add(myarray(k)(0),Valore) 
			On Error Goto 0				
		Next k
		Redim lista(0 To collezione.Count-1, 1)
		For k =1 to collezione.Count
			mySearch2 = orange.createSearchDescriptor()
			mySearch2.searchRegularExpression = False
			mySearch2.SearchWords=True
			mySearch2.searchString            = collezione.item(k)          
			myResult2 = oRange.findAll(mySearch2)
			lista(k-1,0)=ubound(myResult2.getData())+1
			lista(k-1,1)=collezione.item(k)
		Next k
		lista = QuickSort2(lista())
		For k =collezione.Count-1 To 0 Step -1
		thisComponent.sheets(0).Getcellbyposition(i,16+collezione.Count-1-k).Value=lista(k,1)
		thisComponent.sheets(0).Getcellbyposition(i+1,16+collezione.Count-1-k).Value=lista(k,0)
		Next k
	End If
	For k = collezione.Count To 1 Step -1
		collezione.Remove(k)
	Next k
Next i
End Sub

Codice: Seleziona tutto

Function QuickSort2( a(), optional p As long, optional u As long )  as variant
Dim i As long, j As long, m, t
rem a(i,j) ordinamento crescente su i   
    p = iif(IsMissing( p ), lBound(a), p )
    u = iif(IsMissing( u ), uBound(a), u )
   
    i = p
    j = u
    m = a((p + u) / 2)
   
    While (i <= j)
      While (a(i) < m And i < u) : i = i + 1 : Wend
      While (m < a (j) And j> p) : j = j - 1 : Wend

      If (i <= j) Then
        t = a(i)
        a(i) = a(j)
        a(j) = t
        tt=a(i,1)
        a(i,1) = a(j,1)
        a(j,1) = tt
        i = i + 1 :    j = j - 1
      End If
    Wend
    If (p < j) Then QuickSort2(a, p, j)
    If (i < u) Then QuickSort2(a, i, u)
   QuickSort2 =  a
End Function

Codice: Seleziona tutto

For i=0 To 12 Step 3
	thisComponent.sheets(0).Getcellrangebyposition(i,16,i+1,19).ClearContents(1)
	oRange= thisComponent.sheets(0).Getcellrangebyposition(i,9,i,12)

Codice: Seleziona tutto

For i=0 To 18 Step 3
	thisComponent.sheets(0).Getcellrangebyposition(i,16,i+1,19).ClearContents(1)
	oRange= thisComponent.sheets(0).Getcellrangebyposition(i,0,i,12)

Codice: Seleziona tutto

Dim Sh As Object
Dim LastRow As Long

Doc = ThisComponent
Sh = Doc.Sheets.GetByName("Foglio1")
c = Sh.createCursor
c.gotoEndOfUsedArea(false) 
LastRow = c.RangeAddress.EndRow

Codice: Seleziona tutto

Sub Search_Number()
Dim mySearch As Object, myResult As Object, myElement As Object
Dim mySearch2 As Object, myResult2 As Object
Dim Valore As string
Dim i as Integer, k As integer
Dim oRange As Object
Dim collezione As New Collection
Dim Sh As Object
Dim LastRow As Long

Doc = ThisComponent
Sh = Doc.Sheets(0)
c = Sh.createCursor
c.gotoEndOfUsedArea(false) 
LastRow = c.RangeAddress.EndRow

For i=0 To 18 Step 3
	thisComponent.sheets(0).Getcellrangebyposition(i,16,i+1,Lastrow).ClearContents(1)
	oRange= thisComponent.sheets(0).Getcellrangebyposition(i,0,i,12)
	mySearch = orange.createSearchDescriptor()
	mySearch.searchRegularExpression = True
	mySearch.searchString            = "[0-9]*"          
	myResult = oRange.findAll(mySearch)
	If myResult.hasElements Then
		myarray=myResult.getData()
		For k = 0 to Ubound(myarray)
			Valore=Str(myarray(k)(0))
			On Error Resume next
				collezione.Add(myarray(k)(0),Valore) 
			On Error Goto 0				
		Next k
		Redim lista(0 To collezione.Count-1, 1)
		For k =1 to collezione.Count
			mySearch2 = orange.createSearchDescriptor()
			mySearch2.searchRegularExpression = False
			mySearch2.SearchWords=True
			mySearch2.searchString            = collezione.item(k)          
			myResult2 = oRange.findAll(mySearch2)
			lista(k-1,0)=ubound(myResult2.getData())+1
			lista(k-1,1)=collezione.item(k)
		Next k
		lista = QuickSort2(lista())
		For k =collezione.Count-1 To 0 Step -1
		thisComponent.sheets(0).Getcellbyposition(i,16+collezione.Count-1-k).Value=lista(k,1)
		thisComponent.sheets(0).Getcellbyposition(i+1,16+collezione.Count-1-k).Value=lista(k,0)
		Next k
	End If
	For k = collezione.Count To 1 Step -1
		collezione.Remove(k)
	Next k
Next i
End Sub

Codice: Seleziona tutto

For i=0 To 18 Step 3
	If LastRow<16 Then
		LastRow=16
	End if
thisComponent.sheets(0).Getcellrangebyposition(i,16,i+1,Lastrow).ClearContents(1)