[Risolto] Calcolo ripetizione valori parte 3a

Nando69 · Messaggio da **Nando69** » giovedì 1 giugno 2023, 18:27

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

Messaggio da **unlucky83** » giovedì 8 giugno 2023, 17:46

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

Nando69 · Messaggio da **Nando69** » giovedì 8 giugno 2023, 18:07

Ciao Andrea. Grazie. Se volessi includere nel calcolo anche il range A1:S6,cosa occorre fare per favore ?

Messaggio da **unlucky83** » giovedì 8 giugno 2023, 19:18

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

Nando69 · Messaggio da **Nando69** » giovedì 8 giugno 2023, 21:22

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 ?

Messaggio da **unlucky83** » venerdì 9 giugno 2023, 1:19

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

Nando69 · Messaggio da **Nando69** » venerdì 9 giugno 2023, 14:13

Ciao. Ho fatto il copia e incolla integrale della tua ultima macro. Mi dà questo errore

Messaggio da **unlucky83** » venerdì 9 giugno 2023, 16:31

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

Nando69 · Messaggio da **Nando69** » venerdì 9 giugno 2023, 17:17

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

Messaggio da **unlucky83** » venerdì 9 giugno 2023, 18:06

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

Nando69 · Messaggio da **Nando69** » venerdì 9 giugno 2023, 18:28

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

Messaggio da **unlucky83** » venerdì 9 giugno 2023, 18:35

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

Nando69 · Messaggio da **Nando69** » venerdì 9 giugno 2023, 18:53

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

Nando69 · Messaggio da **Nando69** » venerdì 9 giugno 2023, 19:01

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....

Messaggio da **unlucky83** » venerdì 9 giugno 2023, 19:14

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.

Nando69 · Messaggio da **Nando69** » venerdì 9 giugno 2023, 19:15

2 fogli e la macro funziona sul 1°

[Risolto] Calcolo ripetizione valori parte 3a

[Risolto] Calcolo ripetizione valori parte 3a

Re: Calcolo ripetizione valori parte 3a

Re: Calcolo ripetizione valori parte 3a

Re: Calcolo ripetizione valori parte 3a

Re: Calcolo ripetizione valori parte 3a

Re: Calcolo ripetizione valori parte 3a

Re: Calcolo ripetizione valori parte 3a

Re: Calcolo ripetizione valori parte 3a

Re: Calcolo ripetizione valori parte 3a

Re: Calcolo ripetizione valori parte 3a

Re: Calcolo ripetizione valori parte 3a

Re: [Risolto] Calcolo ripetizione valori parte 3a

Re: [Risolto] Calcolo ripetizione valori parte 3a

Re: [Risolto] Calcolo ripetizione valori parte 3a

Re: [Risolto] Calcolo ripetizione valori parte 3a

Re: [Risolto] Calcolo ripetizione valori parte 3a