Ordinamento senza duplicati con bubblesort

Creare una macro - Scrivere uno script - Usare le API
Rispondi
patel
Volontario attivo
Volontario attivo
Messaggi: 4019
Iscritto il: venerdì 30 aprile 2010, 8:04
Località: Livorno

Ordinamento senza duplicati con bubblesort

Messaggio da patel »

In colonna A ho una serie di stringhe che vorrei ordinare con bubblesort eliminando anche i duplicati, prendendo spunto dalla macro di Gaetano per Chimico, ho scritto questa che funziona. Vorrei sapere se è possibile utilizzare un solo array (lista), magari bidimensionale per l'utilizzo di SetDataArray.

Codice: Seleziona tutto

Sub ordina 'bubblesort
Set Dic = CreateObject("Scripting.Dictionary")
REM Si carica la libreria Tools per accedere alla funzione BubbleSortList   
If (Not GlobalScope.BasicLibraries.isLibraryLoaded("Tools")) Then
    GlobalScope.BasicLibraries.LoadLibrary("Tools")
End if  
sh = thiscomponent.Sheets(0)
r= 2
do  
  v = sh.GetCellRangeByName("A" & r).String
  if v = "" then exit do
  If Dic.Exists(v) = False Then 
     Dic.Add v, 0
  end if
  r= r + 1
Loop
iF Dic.count > 0 Then
   n = Dic.count-1
   Redim lista(0 To n) 
   For i = 0 To n
      lista(i) = Dic.Keys()(i)
   Next i
   lista() = BubbleSortList(lista) 
   Dim arr(1 to n+1, 1 To 1) ' <<<< da evitare
   For i = 0 To n
      arr(i+1, 1) = lista(i)
   Next i 
   CellRange = Sh.getCellRangeByName("C1:C" & n+1) 
   CellRange.SetDataArray(arr) 
end if
End sub
-------------------
Libre Office 7.5.3.2 su Windows 11
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
Gaetanopr
Volontario
Volontario
Messaggi: 3300
Iscritto il: mercoledì 21 novembre 2012, 20:07

Re: Ordinamento senza duplicati con bubblesort

Messaggio da Gaetanopr »

Codice: Seleziona tutto

Sub ordina 'bubblesort
Set Dic = CreateObject("Scripting.Dictionary")
REM Si carica la libreria Tools per accedere alla funzione BubbleSortList   
If (Not GlobalScope.BasicLibraries.isLibraryLoaded("Tools")) Then
    GlobalScope.BasicLibraries.LoadLibrary("Tools")
End if  
sh = thiscomponent.Sheets(0)
r= 2
do  
  v = sh.GetCellRangeByName("A" & r).String
  if v = "" then exit do
  If Dic.Exists(v) = False Then 
     Dic.Add v, 0
  end if
  r= r + 1
Loop
iF Dic.count > 0 Then
   n = Dic.count-1
   Redim lista(0 To n, 0) 
   For i = 0 To n
      lista(i, 0) = Dic.Keys()(i)
   Next i
   lista = BubbleSortList(lista())
   CellRange = Sh.getCellRangeByName("C1:C" & n+1) 
   CellRange.SetDataArray(lista) 
end if
End Sub
Hai notato che mette la "q" prima della "p" ?
LibreOffice 7.2.2.2 windows 10
Openoffice 4.1.13 su windows 10
patel
Volontario attivo
Volontario attivo
Messaggi: 4019
Iscritto il: venerdì 30 aprile 2010, 8:04
Località: Livorno

Re: Ordinamento senza duplicati con bubblesort

Messaggio da patel »

grazie Gaetano, non avevo fatto caso al q, però ho notato che dipende dalla disposizione delle lettere, se sono presenti a e b non accade
-------------------
Libre Office 7.5.3.2 su Windows 11
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
Gaetanopr
Volontario
Volontario
Messaggi: 3300
Iscritto il: mercoledì 21 novembre 2012, 20:07

Re: Ordinamento senza duplicati con bubblesort

Messaggio da Gaetanopr »

Bubblesort presenta qualche pecca non è affidabile.
LibreOffice 7.2.2.2 windows 10
Openoffice 4.1.13 su windows 10
patel
Volontario attivo
Volontario attivo
Messaggi: 4019
Iscritto il: venerdì 30 aprile 2010, 8:04
Località: Livorno

Re: Ordinamento senza duplicati con bubblesort

Messaggio da patel »

Temo funzioni soltanto con valori numerici
-------------------
Libre Office 7.5.3.2 su Windows 11
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
Gaetanopr
Volontario
Volontario
Messaggi: 3300
Iscritto il: mercoledì 21 novembre 2012, 20:07

Re: Ordinamento senza duplicati con bubblesort

Messaggio da Gaetanopr »

Il problema è che presenta alcuni bug ho letto, se l'ordinamento lo "ripassi" la p la riordina ma non è una soluzione efficiente, bisognerebbe provare con altri algoritmi.

Codice: Seleziona tutto

lista = BubbleSortList(lista())
   lista = BubbleSortList(lista())
LibreOffice 7.2.2.2 windows 10
Openoffice 4.1.13 su windows 10
patel
Volontario attivo
Volontario attivo
Messaggi: 4019
Iscritto il: venerdì 30 aprile 2010, 8:04
Località: Livorno

Re: Ordinamento senza duplicati con bubblesort

Messaggio da patel »

ho provato con quicksort e funziona

Codice: Seleziona tutto

Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long

  tmpLow = inLow
  tmpHi = inHi

  pivot = vArray((inLow + inHi) \ 2)

  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend

     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend

     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend

  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

Sub ordinaquick 'funziona
Set Dic = CreateObject("Scripting.Dictionary")
REM Si carica la libreria Tools per accedere alla funzione BubbleSortList   
 
sh = thiscomponent.Sheets(0)
r= 2
do  
  v = sh.GetCellRangeByName("A" & r).String
  if v = "" then exit do
  If Dic.Exists(v) = False Then 
     Dic.Add v, 0
  end if
  r= r + 1
Loop
Matrice = ""
iF Dic.count > 0 Then
   n = Dic.count-1
   Redim lista(0 To n) 
   For i = 0 To n
      lista(i) = Dic.Keys()(i)
   Next i
   Call QuickSort(lista, 0, UBound(lista))
   Matrice = Join(lista, " ")
   sh.GetCellRangeByName("B1").String = matrice
   Dim arr(1 to n+1, 1 To 1)
   For i = 0 To n
      arr(i+1, 1) = lista(i)
   Next i 
   CellRange = Sh.getCellRangeByName("C1:C" & n+1) 
   CellRange.SetDataArray(arr) 
end if
End sub
-------------------
Libre Office 7.5.3.2 su Windows 11
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
Gaetanopr
Volontario
Volontario
Messaggi: 3300
Iscritto il: mercoledì 21 novembre 2012, 20:07

Re: Ordinamento senza duplicati con bubblesort

Messaggio da Gaetanopr »

Pure io avevo provato ma mi dava un errore, adesso riprovo
LibreOffice 7.2.2.2 windows 10
Openoffice 4.1.13 su windows 10
Gaetanopr
Volontario
Volontario
Messaggi: 3300
Iscritto il: mercoledì 21 novembre 2012, 20:07

Re: Ordinamento senza duplicati con bubblesort

Messaggio da Gaetanopr »

patel ha scritto:ho provato con quicksort e funziona
Si ma usando due array, all'inizio chiedevi di usarne solo 1.
Prova in questo modo, all'inizio mi dava un errore, veniva fuori un valore nullo, ora ho apportato una modifica al setdataarray e funziona(facendolo dentro la sub del quicksort)

Codice: Seleziona tutto

Sub ordina 
Set Dic = CreateObject("Scripting.Dictionary")
REM Si carica la libreria Tools per accedere alla funzione BubbleSortList   
If (Not GlobalScope.BasicLibraries.isLibraryLoaded("Tools")) Then
    GlobalScope.BasicLibraries.LoadLibrary("Tools")
End if  
sh = thiscomponent.Sheets(0)
r= 2
do  
  v = sh.GetCellRangeByName("A" & r).String
  if v = "" then exit do
  If Dic.Exists(v) = False Then 
     Dic.Add v, 0
  end if
  r= r + 1
Loop
iF Dic.count > 0 Then
   n = Dic.count-1
   Redim lista(0 To n, 0) 
   For i = 0 To n
      lista(i, 0) = Dic.Keys()(i)
   Next i
   QuickSort(lista())
 '  CellRange = Sh.getCellRangeByName("C1:C" & n+1) 
 '  CellRange.SetDataArray(lista) 
end if
End Sub

Sub QuickSort( a(), optional p As long, optional u As long )  as variant
Dim i As long, j As long, m, t
    
    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
		  i = i + 1 :    j = j - 1
		End If
    Wend

    If (p < j) Then QuickSort(a, p, j)
    If (i < u) Then QuickSort(a, i, u)
  
    CellRange = ThisComponent.Sheets(0).getCellRangeByName("C1:C"&Ubound(a)+1) 
    CellRange.SetDataArray(a) 
End Sub
LibreOffice 7.2.2.2 windows 10
Openoffice 4.1.13 su windows 10
patel
Volontario attivo
Volontario attivo
Messaggi: 4019
Iscritto il: venerdì 30 aprile 2010, 8:04
Località: Livorno

Re: Ordinamento senza duplicati con bubblesort

Messaggio da patel »

oppure trasformando la sub in function

Codice: Seleziona tutto

Sub ordina
Set Dic = CreateObject("Scripting.Dictionary")
sh = thiscomponent.Sheets(0)
r= 2
do 
  v = sh.GetCellRangeByName("A" & r).String
  if v = "" then exit do
  If Dic.Exists(v) = False Then
     Dic.Add v, 0
  end if
  r= r + 1
Loop
iF Dic.count > 0 Then
   n = Dic.count-1
   Redim lista(0 To n, 0)
   For i = 0 To n
      lista(i, 0) = Dic.Keys()(i)
   Next i
   lista = QuickSort(lista())
    CellRange = Sh.getCellRangeByName("C1:C"&Ubound(lista)+1)
    CellRange.SetDataArray(lista)
end if
End Sub

Function QuickSort( a(), optional p As long, optional u As long )  as variant
Dim i As long, j As long, m, t
   
    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
        i = i + 1 :    j = j - 1
      End If
    Wend
    If (p < j) Then QuickSort(a, p, j)
    If (i < u) Then QuickSort(a, i, u)
   QuickSort =  a
End Function
Ultima modifica di patel il lunedì 18 marzo 2019, 12:50, modificato 1 volta in totale.
-------------------
Libre Office 7.5.3.2 su Windows 11
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
Gaetanopr
Volontario
Volontario
Messaggi: 3300
Iscritto il: mercoledì 21 novembre 2012, 20:07

Re: Ordinamento senza duplicati con bubblesort

Messaggio da Gaetanopr »

Si, pure in questo modo, credo possiamo chiuderla :super:
LibreOffice 7.2.2.2 windows 10
Openoffice 4.1.13 su windows 10
Rispondi