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