Pagina 1 di 1

Ordinamento senza duplicati con bubblesort

Inviato: venerdì 15 marzo 2019, 19:35
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

Re: Ordinamento senza duplicati con bubblesort

Inviato: sabato 16 marzo 2019, 9:59
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" ?

Re: Ordinamento senza duplicati con bubblesort

Inviato: sabato 16 marzo 2019, 10:45
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

Re: Ordinamento senza duplicati con bubblesort

Inviato: sabato 16 marzo 2019, 18:06
da Gaetanopr
Bubblesort presenta qualche pecca non è affidabile.

Re: Ordinamento senza duplicati con bubblesort

Inviato: domenica 17 marzo 2019, 9:12
da patel
Temo funzioni soltanto con valori numerici

Re: Ordinamento senza duplicati con bubblesort

Inviato: domenica 17 marzo 2019, 12:32
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())

Re: Ordinamento senza duplicati con bubblesort

Inviato: domenica 17 marzo 2019, 12:52
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

Re: Ordinamento senza duplicati con bubblesort

Inviato: domenica 17 marzo 2019, 13:00
da Gaetanopr
Pure io avevo provato ma mi dava un errore, adesso riprovo

Re: Ordinamento senza duplicati con bubblesort

Inviato: lunedì 18 marzo 2019, 11:41
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

Re: Ordinamento senza duplicati con bubblesort

Inviato: lunedì 18 marzo 2019, 12:45
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

Re: Ordinamento senza duplicati con bubblesort

Inviato: lunedì 18 marzo 2019, 12:49
da Gaetanopr
Si, pure in questo modo, credo possiamo chiuderla :super: