[Risolto] Calcolo ripetizione valori parte 3a

Discussioni sull'applicazione per i fogli di calcolo
Rispondi
Nando69
Messaggi: 484
Iscritto il: lunedì 21 settembre 2020, 11:03

[Risolto] Calcolo ripetizione valori parte 3a

Messaggio da Nando69 »

Salve a tutti. Devo ancora una volta rispolverare un problema che qualche tempo fa il gentilissimo Gaetanopr risolse tramite un apposita macro. In questo caso occorrerebbe modificare qualcosa all'interno del codice perchè il quesito si discosta leggermente dal tema precedente. Come da file allegato avrei bisogno che i soli valori (quindi solo numeri) presenti nel range A10-S13,(colonne A,D,G,J,M,P),fossero disposti automaticamente dalla riga 17 in poi,in ordine decrescente,a seconda del numero di volte che questo determinato valore sia presente nella colonne sopracitate. Poichè ad esempio nel range A10-A13,il numero 4 è presente 3 volte e il numero 3 una volta sola,in riga 17 a fianco del 4 dovrà sortire 3 e in riga 18 a fianco del 3 dovrà sortire 1. Per necessità personale nel range A1-S6 ho inserito alcuni numeri e parole ma essi vanno categoricamente esclusi dall'elaborazione della macro (non devono perciò essere presi in considerazione). I valori li ho inseriti ovviamente tutti in modo manuale. Se può essere utile,posto la macro che Gaetano mi aveva elaborato a suo tempo ma per tale contesto non va bene (ho provato) e andrebbero perciò apportate le dovute rettifiche e correzioni. Grazie

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
Allegati
Calcolo ripetizione valori parte 3a.ods
(13.46 KiB) Scaricato 40 volte
Ultima modifica di Nando69 il venerdì 9 giugno 2023, 18:28, modificato 2 volte in totale.
Libre Office 7.3.0.3
Avatar utente
unlucky83
Volontario
Volontario
Messaggi: 2355
Iscritto il: lunedì 7 gennaio 2013, 1:23
Località: Latina

Re: Calcolo ripetizione valori parte 3a

Messaggio da unlucky83 »

Ciao
ho trovato una soluzione piuttosto contorta..forse sono fuori allenamento.
Questa è la macro principale

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
A grandi linee:
1)"myResult" è il risultato della ricerca nell'area interessata per trovare le celle con solo numeri , dato che hai scritto:
Come da file allegato avrei bisogno che i soli valori (quindi solo numeri) presenti nel range A10-S13,(colonne A,D,G,J,M,P),fossero disposti automaticamente dalla riga 17 in poi,
2)"collezione" è una collection per salvarsi i valori senza i doppioni
3)"myResult2" è il risultato della ricerca nell'area interessata per trovare le celle corrispondenti a ciascun valore di "collezione"
4)"lista(_,_)" è un array per salvarsi nel primo campo il conteggio e nel secondo campo il valore che si ripete
5)con la funzione "QuickSort2" ho ordinato in modo ascendente l'array rispetto al primo campo.

La funzione QuickSort2 è la QuickSort da te proposta con la modifica necessaria per ordinare il secondo campo presente:

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
Allegati
Calcolo ripetizione valori parte 3a.ods
(12.71 KiB) Scaricato 27 volte
LibO:Versione: 6.2.8.2
Build ID: 1:6.2.8~rc2-0ubuntu0.16.04.1- 32-bit
-
Se risolvi:
1. Condividi la soluzione qui con noi
2. Metti [Risolto] al titolo del primo messaggio come spiegato qui
Nando69
Messaggi: 484
Iscritto il: lunedì 21 settembre 2020, 11:03

Re: Calcolo ripetizione valori parte 3a

Messaggio da Nando69 »

Ciao Andrea. Grazie. Se volessi includere nel calcolo anche il range A1:S6,cosa occorre fare per favore ?
Libre Office 7.3.0.3
Avatar utente
unlucky83
Volontario
Volontario
Messaggi: 2355
Iscritto il: lunedì 7 gennaio 2013, 1:23
Località: Latina

Re: Calcolo ripetizione valori parte 3a

Messaggio da unlucky83 »

Devi solo modificare la parte iniziale della macro da così

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)
a così

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)
Faccio notare i cambiamenti:
For i=0 To 12 18 Step 3 '18 serve per arrivare fino alla colonna S
oRange= thisComponent.sheets(0).Getcellrangebyposition(i,9 0,i,12) '0 per partire dal rigo 1. L'importante è che nella colonna da rigo1 a rigo 13 i numeri presenti siano solo quelli che vuoi contare. Celle con il testo non danno problemi.

Ci sarebbe un'altro valore da modificare, l'ultimo indice di thisComponent.sheets(0).Getcellrangebyposition(i,16,i+1,19).ClearContents(1)
Al posto del numero 19 dovresti mettere il riferimento all'ultima riga, quindi adottare Lastrow e inserire in testa alla macro

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
Ormai dovresti essere in grado di apportare al codice le modifiche suggerite :D
LibO:Versione: 6.2.8.2
Build ID: 1:6.2.8~rc2-0ubuntu0.16.04.1- 32-bit
-
Se risolvi:
1. Condividi la soluzione qui con noi
2. Metti [Risolto] al titolo del primo messaggio come spiegato qui
Nando69
Messaggi: 484
Iscritto il: lunedì 21 settembre 2020, 11:03

Re: Calcolo ripetizione valori parte 3a

Messaggio da Nando69 »

Ho sostituito :

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)

con :

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)


La parte dove scrivi :

(Ci sarebbe un'altro valore da modificare, l'ultimo indice di thisComponent.sheets(0).Getcellrangebyposition(i,16,i+1,19).ClearContents(1)
Al posto del numero 19 dovresti mettere il riferimento all'ultima riga, quindi adottare Lastrow e inserire in testa alla macro)

con relativo tuo codice :

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


non l'ho capito,scusami. Quale riferimento all'ultima riga ? Quindi adottare? o adattare? Il termine : Lastrow va messo appena dopo la parola : Sub ?
Libre Office 7.3.0.3
Avatar utente
unlucky83
Volontario
Volontario
Messaggi: 2355
Iscritto il: lunedì 7 gennaio 2013, 1:23
Località: Latina

Re: Calcolo ripetizione valori parte 3a

Messaggio da unlucky83 »

Intanto vedo che non hai imparato a "quotare" i messaggi. Hai copiato per intero il mio messaggio e lo hai incollato, ma non c'era bisogno di copiare tutto..potevi limitarti alla parte che ti era poco chiara.
Nessun errore di battitura, volevo proprio intendere la parola "adOttare"

Ti riporto il codice modificato:

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
LibO:Versione: 6.2.8.2
Build ID: 1:6.2.8~rc2-0ubuntu0.16.04.1- 32-bit
-
Se risolvi:
1. Condividi la soluzione qui con noi
2. Metti [Risolto] al titolo del primo messaggio come spiegato qui
Nando69
Messaggi: 484
Iscritto il: lunedì 21 settembre 2020, 11:03

Re: Calcolo ripetizione valori parte 3a

Messaggio da Nando69 »

Ciao. Ho fatto il copia e incolla integrale della tua ultima macro. Mi dà questo errore
Allegati
immagine 9 giugno.jpg
immagine 9 giugno.jpg (80.81 KiB) Visto 939 volte
Libre Office 7.3.0.3
Avatar utente
unlucky83
Volontario
Volontario
Messaggi: 2355
Iscritto il: lunedì 7 gennaio 2013, 1:23
Località: Latina

Re: Calcolo ripetizione valori parte 3a

Messaggio da unlucky83 »

Ti da errore perché non hai copiato e incollato anche la funzione quicksort che ti avevo riportato nell’altro messaggio e nel file che ti avevo allegato
https://forum.openoffice.org/it/forum/v ... 278#p69995
LibO:Versione: 6.2.8.2
Build ID: 1:6.2.8~rc2-0ubuntu0.16.04.1- 32-bit
-
Se risolvi:
1. Condividi la soluzione qui con noi
2. Metti [Risolto] al titolo del primo messaggio come spiegato qui
Nando69
Messaggi: 484
Iscritto il: lunedì 21 settembre 2020, 11:03

Re: Calcolo ripetizione valori parte 3a

Messaggio da Nando69 »

Ho seguito scrupolosamente tutte le tue istruzioni aggiungendo la parte dove c'è quicksort2. Ecco la macro integrale qui sotto. Ho salvato,attivato la macro e mi dà questo errore. Probabilmente sono io che oggi sono fulminato,scusami davvero....

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

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
Allegati
Calcolo ripetizione valori.ods
(14.45 KiB) Scaricato 27 volte
Immagine 9 giugno ore 17.10.jpg
Immagine 9 giugno ore 17.10.jpg (137.48 KiB) Visto 913 volte
Libre Office 7.3.0.3
Avatar utente
unlucky83
Volontario
Volontario
Messaggi: 2355
Iscritto il: lunedì 7 gennaio 2013, 1:23
Località: Latina

Re: Calcolo ripetizione valori parte 3a

Messaggio da unlucky83 »

Bene.
Ti da quell'errore perchè hai gia cancellato manualmente le righe da 16 in giù, prova che non avevo effettuato perchè la macro provvede da sola a eliminare i vecchi elenchi. E' opportuno aggiustare la macro principale per risolvere il problema.
Subito dopo il for aggiungi questo if

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)
Ti esorto ad usare l'editor completo per scrivere i messaggi e i tag che consentono di riportare i codici macro in modo opportuno oltre a quotare i messaggi, non penso sia chiedere troppo.
Grazie
LibO:Versione: 6.2.8.2
Build ID: 1:6.2.8~rc2-0ubuntu0.16.04.1- 32-bit
-
Se risolvi:
1. Condividi la soluzione qui con noi
2. Metti [Risolto] al titolo del primo messaggio come spiegato qui
Nando69
Messaggi: 484
Iscritto il: lunedì 21 settembre 2020, 11:03

Re: Calcolo ripetizione valori parte 3a

Messaggio da Nando69 »

Ok,ho fatto come hai detto,mi dà questo errore. Chiudo il topic perchè sono una testa di c...o,in quanto non riesco a capire bene le cose. Scusami tantissimo,non volevo recarti tuto questo distrubo,credimi. Buona serata
Allegati
Immagine 18.25.jpg
Immagine 18.25.jpg (80.71 KiB) Visto 890 volte
Libre Office 7.3.0.3
Avatar utente
unlucky83
Volontario
Volontario
Messaggi: 2355
Iscritto il: lunedì 7 gennaio 2013, 1:23
Località: Latina

Re: [Risolto] Calcolo ripetizione valori parte 3a

Messaggio da unlucky83 »

Non demordere.
Io provandolo sul primo file che hai allegato non ho alcun problema.
Tu lo stai provando su un altro file con più schede? Puoi allegarlo?
intanto ti allego il mio
Allegati
Calcolo ripetizione valori parte 3a_unlucky83_V1.ods
(13.08 KiB) Scaricato 34 volte
LibO:Versione: 6.2.8.2
Build ID: 1:6.2.8~rc2-0ubuntu0.16.04.1- 32-bit
-
Se risolvi:
1. Condividi la soluzione qui con noi
2. Metti [Risolto] al titolo del primo messaggio come spiegato qui
Nando69
Messaggi: 484
Iscritto il: lunedì 21 settembre 2020, 11:03

Re: [Risolto] Calcolo ripetizione valori parte 3a

Messaggio da Nando69 »

Questa è la 1a macro di questo topic che mi hai mandato,solo range A10-S13 e funziona perfettamente

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


Questa invece è la macro integrale con la tua ultima parte modificata,comprensivo di range A3-S6,quindi A3-S13 e non funziona. Non c'è Santo che tenga....Nada de nada....O sono che io sono rincogl...to o cos'altro non so

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
If LastRow<16 Then
LastRow=16
End if
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

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
Libre Office 7.3.0.3
Nando69
Messaggi: 484
Iscritto il: lunedì 21 settembre 2020, 11:03

Re: [Risolto] Calcolo ripetizione valori parte 3a

Messaggio da Nando69 »

Ok,adesso funziona. Ho 2 fogli. Ho riprovato con la tua precedente (penultima) macro e adesso funziona tutto. Grazie mille e scusami ancora per tutto il fastidio che ti ho dato....
Allegati
Calcolo ripetizione valori 2.ods
(14.94 KiB) Scaricato 27 volte
Libre Office 7.3.0.3
Avatar utente
unlucky83
Volontario
Volontario
Messaggi: 2355
Iscritto il: lunedì 7 gennaio 2013, 1:23
Località: Latina

Re: [Risolto] Calcolo ripetizione valori parte 3a

Messaggio da unlucky83 »

ok bene.
Ti ho chiesto quanti fogli hai nel file perchè la macro cosi com'è lavora solo sul primo foglio perchè ho usato "sheets(0)" per selezionare il foglio.
LibO:Versione: 6.2.8.2
Build ID: 1:6.2.8~rc2-0ubuntu0.16.04.1- 32-bit
-
Se risolvi:
1. Condividi la soluzione qui con noi
2. Metti [Risolto] al titolo del primo messaggio come spiegato qui
Nando69
Messaggi: 484
Iscritto il: lunedì 21 settembre 2020, 11:03

Re: [Risolto] Calcolo ripetizione valori parte 3a

Messaggio da Nando69 »

2 fogli e la macro funziona sul 1°
Libre Office 7.3.0.3
Rispondi